Eliot Miranda uploaded a new version of VMMaker to project VM Maker:
http://source.squeak.org/VMMaker/VMMaker.oscog-eem.925.mcz
==================== Summary ====================
Name: VMMaker.oscog-eem.925
Author: eem
Time: 13 November 2014, 3:26:35.888 pm
UUID: 78aa3501-bb68-484a-967e-8315ecc0165d
Ancestors: VMMaker.oscog-eem.924
Fix recursive def of ObjectMemory>>wordSize and
comment the relevant implementations.
=============== Diff against VMMaker.oscog-eem.924 ===============
Item was removed:
- ----- Method: NewCoObjectMemorySimulator>>wordSize (in category 'memory access') -----
- wordSize
- ^4!
Item was removed:
- ----- Method: NewObjectMemorySimulator>>wordSize (in category 'memory access') -----
- wordSize
- ^4!
Item was changed:
----- Method: ObjectMemory>>wordSize (in category 'interpreter access') -----
wordSize
+ "Answer the manager's word size, which is assumed to be equivalent to the underlying machine's word size."
+ ^4!
- "Answer the width of an object pointer, in bytes."
-
- ^self wordSize!
Item was changed:
----- Method: Spur32BitMemoryManager class>>wordSize (in category 'word size') -----
wordSize
+ "Answer the manager's word size, which is the size of an oop, and which
+ is assumed to be equivalent to the underlying machine's word size."
^4!
Item was changed:
----- Method: Spur32BitMemoryManager>>wordSize (in category 'word size') -----
wordSize
+ "Answer the manager's word size, which is the size of an oop, and which
+ is assumed to be equivalent to the underlying machine's word size."
<api>
<cmacro: '() 4'>
^4!
Item was changed:
----- Method: Spur64BitMemoryManager class>>wordSize (in category 'word size') -----
wordSize
+ "Answer the manager's word size, which is the size of an oop, and which
+ is assumed to be equivalent to the underlying machine's word size."
^8!
Item was changed:
----- Method: Spur64BitMemoryManager>>wordSize (in category 'word size') -----
wordSize
+ "Answer the manager's word size, which is the size of an oop, and which
+ is assumed to be equivalent to the underlying machine's word size."
<cmacro: '() 8'>
^8!
Item was changed:
----- Method: SpurMemoryManager class>>wordSize (in category 'word size') -----
wordSize
+ "Answer the manager's word size, which is the size of an oop, and which
+ is assumed to be equivalent to the underlying machine's word size."
^self subclassResponsibility!
Item was changed:
----- Method: SpurMemoryManager>>wordSize (in category 'word size') -----
wordSize
+ "Answer the manager's word size, which is the size of an oop, and which
+ is assumed to be equivalent to the underlying machine's word size."
- "Answer the manager's word size, whjich is the size of an oop, and which
- is assumed to be equivslent to the underlying machine's word size."
^self subclassResponsibility!
1
0
Bert Freudenberg uploaded a new version of VMMakerJS to project VM Maker:
http://source.squeak.org/VMMaker/VMMakerJS-bf.17.mcz
==================== Summary ====================
Name: VMMakerJS-bf.17
Author: bf
Time: 14 November 2014, 12:21:43.312 am
UUID: 399be48b-95d8-4722-bdcc-39a94a12c486
Ancestors: VMMakerJS-bf.16
Make generated pointer math more readable.
=============== Diff against VMMakerJS-bf.16 ===============
Item was changed:
----- Method: JSPluginCodeGenerator>>emitJSHeaderOn: (in category 'JS code generator') -----
emitJSHeaderOn: aStream
"Write a JS file header onto the given stream."
aStream nextPutAll: '/* '.
aStream nextPutAll: (VMMaker headerNotice copyReplaceAll: ' C ' with: ' JS ').
aStream nextPutAll: ' */';cr.
aStream nextPutAll: (self fileHeaderVersionStampForSourceClass: vmClass).
aStream nextPutAll: '
module("users.bert.SqueakJS.plugins.', pluginName, '").requires("users.bert.SqueakJS.vm").toRun(function() {
var VM_PROXY_MAJOR = ', InterpreterPrimitives vmProxyMajorVersion, ';
var VM_PROXY_MINOR = ', InterpreterPrimitives vmProxyMinorVersion, ';
/*** Functions ***/
function CLASSOF(obj) { return typeof obj === "number" ? interpreterProxy.classSmallInteger() : obj.sqClass }
function SIZEOF(obj) { return obj.pointers ? obj.pointers.length : obj.words ? obj.words.length : obj.bytes ? obj.bytes.length : 0 }
function BYTESIZEOF(obj) { return obj.bytes ? obj.bytes.length : obj.words ? obj.words.length * 4 : 0 }
function DIV(a, b) { return Math.floor(a / b) | 0; } // integer division
function MOD(a, b) { return a - DIV(a, b) * b | 0; } // signed modulus
function SHL(a, b) { return b > 31 ? 0 : a << b; } // fix JS shift
function SHR(a, b) { return b > 31 ? 0 : a >>> b; } // fix JS shift
function SHIFT(a, b) { return b < 0 ? (b < -31 ? 0 : a >>> (0-b) ) : (b > 31 ? 0 : a << b); }
+ function PTR_ADD(p, n) { return new Int32Array(p.buffer, p.byteOffset + n * 4); }
+ function FPTR_ADD(p, n) { return new Float32Array(p.buffer, p.byteOffset + n * 4); }
'.!
Item was changed:
----- Method: TSendNode>>emitJSPointerArithmetic:on:level:generator:type:top: (in category '*vmmakerjs') -----
emitJSPointerArithmetic: type on: aStream level: level generator: aGenerator type: cType top: top
(selector = #+) ifFalse: [self halt].
receiver isVariable
+ ifTrue: [ | func |
+ func := ({'int' -> 'PTR_ADD'. 'float' -> 'FPTR_ADD'} as: Dictionary)
- ifTrue: [ | typeAndSize |
- typeAndSize := ({'int' -> #('Int32Array' 4). 'float' -> #('Float32Array' 4)} as: Dictionary)
at: ((cType copyUpTo: $*) copyWithout: $ ).
+ aStream nextPutAll: func, '(', receiver name, ', ']
- aStream nextPutAll: ('new {1}({2}.buffer, {2}.byteOffset + {3} * ('
- format: {typeAndSize first. receiver name. typeAndSize second})]
ifFalse: [receiver emitJSPointerArithmetic: type on: aStream level: level generator: aGenerator type: cType top: false.
aStream nextPutAll: ' + '].
aGenerator emitJSExpression: arguments first on: aStream.
+ top ifTrue: [aStream nextPutAll: ')'].!
- top ifTrue: [aStream nextPutAll: '))'].!
1
0
Bert Freudenberg uploaded a new version of VMMakerJS to project VM Maker:
http://source.squeak.org/VMMaker/VMMakerJS-bf.16.mcz
==================== Summary ====================
Name: VMMakerJS-bf.16
Author: bf
Time: 13 November 2014, 7:08:06.162 pm
UUID: aa9fd3da-7901-4c62-ae34-c166f1492d3b
Ancestors: VMMakerJS-bf.15
Balloon2D needs pointer arithmetic. Fake it.
How? If p is a 'pointer' to an Int32Array, then
p += offset
becomes
p = new Int32Array(p.buffer, p.byteOffset + 4 * offset)
This is actually more efficient than it looks. The Int32Array is just an object holding a buffer, and offset. Allocating this is cheap, and it's going to be GC'ed quickly. The resulting plugin is actually twice as fast as my home-grown one.
=============== Diff against VMMakerJS-bf.15 ===============
Item was changed:
----- Method: JSCodeGenerator class>>translateAllPluginsIn: (in category 'utilities') -----
translateAllPluginsIn: aDirectory
self beActiveDuring: [
#( ADPCMCodecPlugin
+ BalloonEnginePlugin
"BMPReadWriterPlugin -- not working yet"
BitBltSimulation
+ "DSAPlugin --not working yet"
- DSAPlugin
DeflatePlugin
FFTPlugin
FloatArrayPlugin
+ GeniePlugin "-- not working yet"
- "GeniePlugin -- not working yet"
JPEGReaderPlugin
KedamaPlugin
KedamaPlugin2
KlattSynthesizerPlugin
LargeIntegersPlugin
Matrix2x3Plugin
MiscPrimitivePlugin
ScratchPlugin
SoundGenerationPlugin
StarSqueakPlugin
) do: [:pluginName |
self environment at: pluginName ifPresent: [:plugin |
plugin translateInDirectory: aDirectory doInlining: false]]
displayingProgress: 'Generating JS plugins'].!
Item was changed:
----- Method: JSCodeGenerator>>checkNonPointer:op: (in category 'private') -----
checkNonPointer: node op: op
+ self ifPointerVar: node then: [:type |
+ self halt: 'cannot do ', op, ' with ', type]!
- node isVariable
- ifTrue: [(self typeOfVariable: node name) ifNotNil: [:type |
- (type includes: $*) ifTrue: [self halt: 'cannot do ', op, ' with ', type]]].!
Item was changed:
----- Method: JSCodeGenerator>>generateAt:on:indent: (in category 'JS translation') -----
generateAt: msgNode on: aStream indent: level
"Generate the JS code for this message onto the given stream."
+ | arrayNode indexNode subtractOne complex coerceTo |
- | arrayNode indexNode subtractOne complex |
arrayNode := msgNode receiver.
+ (arrayNode isSend and: [arrayNode selector = #cCoerce:to: and: [arrayNode args first isVariable]]) ifTrue: [
+ coerceTo := (arrayNode args second value) copyWithout: $ .
+ arrayNode := arrayNode args first.
+ aStream nextPutAll: '('].
indexNode := msgNode args first.
subtractOne := self isOneBasedArray: arrayNode name in: currentMethod.
(subtractOne and: [indexNode isPlusOne]) ifTrue: [
subtractOne := false.
indexNode := indexNode receiver. "remove + 1"
].
complex := subtractOne and: [indexNode isLeafOrFunc not].
self emitJSExpression: arrayNode on: aStream.
aStream nextPut: $[.
complex ifTrue: [aStream nextPut: $(].
indexNode emitJSCodeAsExpressionOn: aStream level: level + 1 generator: self.
complex ifTrue: [aStream nextPut: $)].
subtractOne ifTrue: [aStream nextPutAll: ' - 1'].
+ aStream nextPut: $].
+ coerceTo ifNotNil: [
+ coerceTo = 'int*' ifFalse: [self halt].
+ aStream nextPutAll: '|0)'].
+ !
- aStream nextPut: $].!
Item was changed:
----- Method: JSCodeGenerator>>generateAtPut:on:indent: (in category 'JS translation') -----
generateAtPut: msgNode on: aStream indent: level
"Generate the JS code for this message onto the given stream."
| putExpr incExpr |
+ (msgNode receiver isSend and: [msgNode receiver selector = #cCoerce:to:]) ifTrue: [
+ msgNode receiver args asString = '{deltaST . ''int *''}'
+ ifTrue: [msgNode receiver: msgNode receiver args first]]. "HACK!!"
self generateAt: msgNode on: aStream indent: level.
(putExpr := msgNode args last) isPlusOne ifTrue: [
((incExpr := putExpr receiver) isSend and: [incExpr selector = #at: and: [
incExpr receiver asString = msgNode receiver asString and: [
incExpr args first asString = msgNode args first asString]]])
ifTrue: [^aStream nextPutAll: '++'.]].
aStream nextPutAll: ' = '.
self emitJSExpression: putExpr on: aStream!
Item was changed:
----- Method: JSCodeGenerator>>generateBitShift:on:indent: (in category 'JS translation') -----
generateBitShift: msgNode on: aStream indent: level
"Generate the JS code for this message onto the given stream."
| arg rcvr |
arg := msgNode args first.
rcvr := msgNode receiver.
arg isConstant ifTrue: [
"bit shift amount is a constant"
- self emitJSExpression: rcvr on: aStream.
arg value < 0 ifTrue: [
+ "skip unneeded coercion to unsigned"
+ (rcvr isSend and: [rcvr selector = #cCoerce:to: and: [rcvr args second value = 'unsigned']])
+ ifTrue: [self emitJSExpression: rcvr args first on: aStream]
+ ifFalse: [self emitJSExpression: rcvr on: aStream].
aStream nextPutAll: ' >>> ', arg value negated printString.
] ifFalse: [
+ self emitJSExpression: rcvr on: aStream.
aStream nextPutAll: ' << ', arg value printString.
].
] ifFalse: [
"bit shift amount is an expression"
aStream nextPutAll: 'SHIFT('.
self emitJSExpression: rcvr on: aStream.
aStream nextPutAll: ', '.
self emitJSExpression: arg on: aStream.
aStream nextPutAll: ')'.
].!
Item was changed:
----- Method: JSCodeGenerator>>generateCCoercion:on:indent: (in category 'JS translation') -----
generateCCoercion: msgNode on: aStream indent: level
"Generate the JS code for this message onto the given stream."
| expr cType |.
expr := msgNode args first.
cType := msgNode args second value.
(expr isSend and: [expr receiver name = 'interpreterProxy' and: [expr selector = #firstIndexableField:]]) ifTrue: [
cType := msgNode args second value.
self emitJSExpression: expr args first on: aStream.
cType = 'unsigned char *' ifTrue: [^aStream nextPutAll: '.bytes'].
cType = 'unsigned int *' ifTrue: [^aStream nextPutAll: '.words'].
cType = 'int *' ifTrue: [^aStream nextPutAll: '.wordsAsInt32Array()'].
cType = 'short *' ifTrue: [^aStream nextPutAll: '.wordsAsInt16Array()'].
cType = 'float *' ifTrue: [^aStream nextPutAll: '.wordsAsFloat32Array()'].
cType = 'double *' ifTrue: [^aStream nextPutAll: '.wordsAsFloat64Array()'].
self halt.
] ifFalse: [
+ (#('int') includes: cType) ifTrue: [
- (#('int' 'unsigned int') includes: cType) ifTrue: [
aStream nextPutAll: '('.
self emitJSExpression: expr on: aStream.
^aStream nextPutAll: '|0)'].
+ (#('unsigned int' 'unsigned' ) includes: cType) ifTrue: [
+ aStream nextPutAll: '('.
+ self emitJSExpression: expr on: aStream.
+ ^ aStream nextPutAll: '>>>0)'].
+ ((#('double' 'float') includes: cType) or: [('sqInt (*)(*)'match: cType)
+ or: [#(transformPoint:into:) includes: currentMethod selector]])
- ((#('double' 'float') includes: cType) or: ['sqInt (*)(*)'match: cType])
ifFalse: [self halt].
self emitJSExpression: expr on: aStream.
]
!
Item was changed:
----- Method: JSCodeGenerator>>generateDivide:on:indent: (in category 'JS translation') -----
generateDivide: msgNode on: aStream indent: level
"Generate the JS code for this message onto the given stream."
| rcvr arg divisor |
rcvr := msgNode receiver.
arg := msgNode args first.
msgNode selector == #/ ifTrue: [
+ (#('Matrix2x3Plugin' 'ScratchPlugin' 'FloatArrayPlugin' 'KedamaPlugin' 'KedamaPlugin2' 'FFTPlugin' 'Klatt' 'B2DPlugin') includes: self pluginName) ifFalse: [self halt: msgNode].
- (#('Matrix2x3Plugin' 'ScratchPlugin' 'FloatArrayPlugin' 'KedamaPlugin' 'KedamaPlugin2' 'FFTPlugin' 'Klatt') includes: self pluginName) ifFalse: [self halt].
self emitJSExpression: rcvr on: aStream.
aStream nextPutAll: ' / '.
^self emitJSExpression: arg on: aStream].
(arg isConstant and:
[UseRightShiftForDivide and:
[(divisor := arg value) isInteger and:
[divisor isPowerOfTwo and:
[divisor > 0 and:
[divisor <= (1 bitShift: 31)]]]]])
ifTrue: [
"use signed (arithmetic) right shift instead of divide"
self emitJSExpression: rcvr on: aStream.
aStream nextPutAll: ' >> ', (divisor log: 2) asInteger printString.
] ifFalse: [
"use float divide and coerce to integer"
aStream nextPutAll: 'DIV('.
self emitJSExpression: rcvr on: aStream.
aStream nextPutAll: ', '.
self emitJSExpression: arg on: aStream.
aStream nextPutAll: ')'.
].
!
Item was changed:
----- Method: JSCodeGenerator>>generateFirstIndexableField:on:indent: (in category 'JS hacks') -----
generateFirstIndexableField: msgNode on: aStream indent: level
| parent cType accessor |
self oneBasedArrays: false.
"HACK: detect cType from parent node"
parent := thisContext sender sender sender.
cType := parent method == (TAssignmentNode>>#emitJSCodeOn:level:generator:)
ifTrue: [self typeOfVariable: parent receiver variable name] ifFalse: [
parent method == (TSendNode>>#emitJSCodeAsFunctionCallOn:level:generator:)
ifTrue: [self typeOfArgument: (parent receiver args indexOf: msgNode) in: parent receiver selector] ifFalse: [
msgNode asString = 'interpreterProxy firstIndexableField: mapOop'
ifTrue: ['unsigned int*'] ifFalse: [
msgNode asString = 'interpreterProxy firstIndexableField: blockOop'
ifTrue: ['int*'] ifFalse: [
+ parent method == (TReturnNode>>#emitJSCodeOn:level:generator:)
+ ifTrue: [currentMethod returnType] ifFalse: [
+ self halt]]]]].
- self halt]]]].
cType ifNotNil: [
cType := cType copyReplaceAll: ' *' with: '* '.
accessor := (cType beginsWith: 'unsigned char*') ifTrue: ['.bytes']
ifFalse: [(cType beginsWith: 'unsigned int*') ifTrue: ['.words']
ifFalse: [(cType beginsWith: 'int*') ifTrue: ['.wordsAsInt32Array()']
ifFalse: [(cType beginsWith: 'char*') ifTrue: ['.bytes']
ifFalse: [(cType beginsWith: 'float*') ifTrue: ['.wordsAsFloat32Array()']
ifFalse: [self halt: 'need to handle ', cType]]]]].
accessor ifNotNil: [msgNode args first emitJSCodeOn: aStream level: level generator: self.
^aStream nextPutAll: accessor]].
"generic code below, not needed ever hopefully"
aStream nextPutAll: 'interpreterProxy.'.
^ msgNode emitJSCodeAsFunctionCallOn: aStream level: level generator: self!
Item was added:
+ ----- Method: JSCodeGenerator>>generateLoadPointInt:on:indent: (in category 'JS hacks') -----
+ generateLoadPointInt: msgNode on: aStream indent: level
+ aStream nextPutAll: '('.
+ self emitJSExpression: msgNode args second on: aStream.
+ aStream nextPutAll: '['.
+ self emitJSExpression: msgNode args first on: aStream.
+ aStream nextPutAll: ']|0)'.
+ !
Item was added:
+ ----- Method: JSCodeGenerator>>generateLoadPointShort:on:indent: (in category 'JS hacks') -----
+ generateLoadPointShort: msgNode on: aStream indent: level
+ msgNode args second isVariable ifFalse: [self halt].
+ msgNode args second name = 'points' ifFalse: [self halt].
+ aStream nextPutAll: '(points.int16Array || (points.int16Array = new Int16Array(points.buffer, points.byteOffset)))['.
+ msgNode args first emitJSCodeAsExpressionOn: aStream level: 0 generator: self.
+ aStream nextPutAll: ']'.
+ !
Item was added:
+ ----- Method: JSCodeGenerator>>generateMakeUnsignedFrom:on:indent: (in category 'JS hacks') -----
+ generateMakeUnsignedFrom: msgNode on: aStream indent: level
+ "Generate the JS code for this message onto the given stream."
+ | expr type coerce |
+ msgNode args size = 1 ifFalse: [self halt].
+ expr := msgNode args first.
+ (expr isSend and: [expr selector = #at:])
+ ifFalse: [^self emitJSExpression: expr on: aStream].
+ coerce := expr receiver.
+ (coerce isSend and: [coerce selector = #cCoerce:to:])
+ ifFalse: [^self emitJSExpression: expr on: aStream].
+ type := (coerce args second value) copyWithout: $ .
+ type = 'int*' ifFalse: [self halt].
+ self emitJSExpression: coerce args first on: aStream.
+ aStream nextPut: $[.
+ expr args first emitJSCodeAsExpressionOn: aStream level: 0 generator: self.
+ aStream nextPut: $].
+ !
Item was changed:
----- Method: JSCodeGenerator>>generatePlus:on:indent: (in category 'JS translation') -----
generatePlus: msgNode on: aStream indent: level
"Generate the JS code for this message onto the given stream."
msgNode receiver isBitBltPtr ifFalse: [
- self checkNonPointer: msgNode receiver op: '+'.
self checkNonPointer: msgNode args first op: '+'.
+ self ifPointerVar: msgNode receiver then: [:type |
+ (self generatePointerPlus: msgNode type: type on: aStream indent: level)
+ ifTrue: [^self].
+ self halt: 'cannot do + with ', type].
self emitJSExpression: msgNode receiver on: aStream.
aStream nextPutAll: ' + '].
self emitJSExpression: msgNode args first on: aStream.!
Item was added:
+ ----- Method: JSCodeGenerator>>generatePointerPlus:type:on:indent: (in category 'JS translation') -----
+ generatePointerPlus: msgNode type: type on: aStream indent: level
+ "Generate the JS code for this message onto the given stream."
+ (#('B2DPlugin' 'GeniePlugin') includes: self pluginName) ifFalse: [self halt].
+ msgNode emitJSPointerArithmetic: type on: aStream level: level generator: self type: type top: true.
+ ^true
+ !
Item was added:
+ ----- Method: JSCodeGenerator>>ifPointerVar:then: (in category 'private') -----
+ ifPointerVar: node then: aBlock
+ (node isSend and: [node selector = #+]) ifTrue: [
+ ^self ifPointerVar: node receiver then: aBlock].
+ node isVariable ifTrue: [
+ (self typeOfVariable: node name) ifNotNil: [:type |
+ (type includes: $*) ifTrue: [aBlock value: type]]].
+ !
Item was changed:
----- Method: JSCodeGenerator>>initialize (in category 'public') -----
initialize
translationDict := Dictionary new.
inlineList := Array new.
constants := Dictionary new: 100.
variables := OrderedCollection new: 100.
variableDeclarations := Dictionary new: 100.
methods := Dictionary new: 500.
macros := Dictionary new.
+ self initializeJSTranslationDictionary.
- self initializeCTranslationDictionary.
receiverDict := Dictionary new.
headerFiles := OrderedCollection new.
globalVariableUsage := Dictionary new.
useSymbolicConstants := true.
generateDeadCode := false.
scopeStack := OrderedCollection new.
logger := (ProvideAnswerNotification new tag: #logger; signal) ifNil: [Transcript].
pools := IdentitySet new.
abstractDeclarations := IdentitySet new.
uncheckedAbstractMethods := OrderedCollection new.
!
Item was removed:
- ----- Method: JSCodeGenerator>>initializeCTranslationDictionary (in category 'JS translation') -----
- initializeCTranslationDictionary
- "Initialize the dictionary mapping message names to actions for C code generation."
-
- | pairs |
- translationDict := Dictionary new: 200.
- pairs := #(
- #& #generateAnd:on:indent:
- #| #generateOr:on:indent:
- #and: #generateSequentialAnd:on:indent:
- #or: #generateSequentialOr:on:indent:
- #not #generateNot:on:indent:
-
- #+ #generatePlus:on:indent:
- #- #generateMinus:on:indent:
- #negated #generateNegated:on:indent:
- #abs #generateMath:on:indent:
- #sqrt #generateMath:on:indent:
- #sin #generateMath:on:indent:
- #cos #generateMath:on:indent:
- #tan #generateMath:on:indent:
- #atan #generateMath:on:indent:
- #exp #generateMath:on:indent:
- #log #generateMath:on:indent:
- #* #generateTimes:on:indent:
- #/ #generateDivide:on:indent:
- #// #generateDivide:on:indent:
- #\\ #generateModulo:on:indent:
- #<< #generateShiftLeft:on:indent:
- #>> #generateShiftRight:on:indent:
- #min: #generateMin:on:indent:
- #max: #generateMax:on:indent:
- #between:and: #generateBetweenAnd:on:indent:
-
- #bitAnd: #generateBitAnd:on:indent:
- #bitOr: #generateBitOr:on:indent:
- #bitXor: #generateBitXor:on:indent:
- #bitShift: #generateBitShift:on:indent:
- #signedBitShift: #generateSignedBitShift:on:indent:
- #bitInvert32 #generateBitInvert32:on:indent:
- #bitClear: #generateBitClear:on:indent:
-
- #< #generateLessThan:on:indent:
- #<= #generateLessThanOrEqual:on:indent:
- #= #generateEqual:on:indent:
- #> #generateGreaterThan:on:indent:
- #>= #generateGreaterThanOrEqual:on:indent:
- #~= #generateNotEqual:on:indent:
- #== #generateEqual:on:indent:
- #~~ #generateNotEqual:on:indent:
- #isNil #generateIsNil:on:indent:
- #notNil #generateNotNil:on:indent:
-
- #whileTrue: #generateWhileTrue:on:indent:
- #whileFalse: #generateWhileFalse:on:indent:
- #whileTrue #generateDoWhileTrue:on:indent:
- #whileFalse #generateDoWhileFalse:on:indent:
- #to:do: #generateToDo:on:indent:
- #to:by:do: #generateToByDo:on:indent:
- #repeat #generateRepeat:on:indent:
-
- #ifTrue: #generateIfTrue:on:indent:
- #ifFalse: #generateIfFalse:on:indent:
- #ifTrue:ifFalse: #generateIfTrueIfFalse:on:indent:
- #ifFalse:ifTrue: #generateIfFalseIfTrue:on:indent:
-
- #at: #generateAt:on:indent:
- #at:put: #generateAtPut:on:indent:
- #basicAt: #generateAt:on:indent:
- #basicAt:put: #generateAtPut:on:indent:
-
- #integerValueOf: #generateIntegerValueOf:on:indent:
- #integerObjectOf: #generateIntegerObjectOf:on:indent:
- #isIntegerObject: #generateIsIntegerObject:on:indent:
- #cCode: #generateInlineCCode:on:indent:
- #cCode:inSmalltalk: #generateInlineCCode:on:indent:
- #cPreprocessorDirective: #generateInlineCPreprocessorDirective:on:indent:
- #preprocessorExpression: #generateInlineCppDirective:on:indent:
- #isDefined:inSmalltalk:comment:ifTrue: #generateInlineCppIfDef:on:indent:
- #isDefined:inSmalltalk:comment:ifTrue:ifFalse: #generateInlineCppIfDefElse:on:indent:
- #isDefinedTrueExpression:inSmalltalk:comment:ifTrue:ifFalse: #generateInlineCppIfElse:on:indent:
- #cCoerce:to: #generateCCoercion:on:indent:
- #cCoerceSimple:to: #generateCCoercion:on:indent:
- #addressOf: #generateAddressOf:on:indent:
- #signedIntFromLong #generateSignedIntFromLong:on:indent:
- #signedIntToLong #generateSignedIntToLong:on:indent:
- #signedIntFromShort #generateSignedIntFromShort:on:indent:
- #signedIntToShort #generateSignedIntToShort:on:indent:
- #preIncrement #generatePreIncrement:on:indent:
- #preDecrement #generatePreDecrement:on:indent:
- #inline: #generateInlineDirective:on:indent:
- #asFloat #generateAsFloat:on:indent:
- #asInteger #generateAsInteger:on:indent:
- #asUnsignedInteger #generateAsUnsignedInteger:on:indent:
- #asSymbol #generateAsSymbol:on:indent:
- #anyMask: #generateBitAnd:on:indent:
- #raisedTo: #generateRaisedTo:on:indent:
- #touch: #generateTouch:on:indent:
- #bytesPerWord #generateBytesPerWord:on:indent:
- #baseHeaderSize #generateBaseHeaderSize:on:indent:
-
- #sharedCodeNamed:inCase: #generateSharedCodeDirective:on:indent:
-
- #perform: #generatePerform:on:indent:
- #perform:with: #generatePerform:on:indent:
- #perform:with:with: #generatePerform:on:indent:
- #perform:with:with:with: #generatePerform:on:indent:
- #perform:with:with:with:with: #generatePerform:on:indent:
- #perform:with:with:with:with:with: #generatePerform:on:indent:
-
- #shouldNotImplement #generateSmalltalkMetaError:on:indent:
- #shouldBeImplemented #generateSmalltalkMetaError:on:indent:
-
- "optimized interpreterProxy calls"
- #firstIndexableField: #generateFirstIndexableField:on:indent:
- #slotSizeOf: #generateSlotSizeOf:on:indent:
- #stSizeOf: #generateSlotSizeOf:on:indent:
- #byteSizeOfBytes: #generateByteSizeOf:on:indent:
- #byteSizeOf: #generateByteSizeOf:on:indent:
- #fetchClassOf: #generateFetchClassOf:on:indent:
- #superclassOf: #generateSuperclassOf:on:indent:
- #instanceSizeOf: #generateInstanceSizeOf:on:indent:
- #is:KindOf: #generateIsKindOf:on:indent:
- #isFloatObject: #generateIsFloatObject:on:indent:
- #cDigitCopyFrom:to:len: #generateCDigitCopy:on:indent:
- #sizeOfSTArrayFromCPrimitive: #generateSizeOfSTArrayFromCPrimitive:on:indent:
- #asciiValue #generateIdentityUnary:on:indent:
- #primitiveFail #generateInterpreterProxyCall:on:indent:
- #intAtPointer: #generateIntAtPointer:on:indent:
- #byteAtPointer: #generateByteAtPointer:on:indent:
- #oopForPointer: #generateOopForPointer:on:indent:
- #long32At: #generateLong32At:on:indent:
- #srcLongAt: #generateSrcLongAt:on:indent:
- #dstLongAt: #generateDstLongAt:on:indent:
- #dstLongAt:put: #generateDstLongAtPut:on:indent:
- ).
-
- 1 to: pairs size by: 2 do: [:i |
- translationDict at: (pairs at: i) put: (pairs at: i + 1)].
-
- pairs := #(
- #ifTrue: #generateIfTrueAsArgument:on:indent:
- #ifFalse: #generateIfFalseAsArgument:on:indent:
- #ifTrue:ifFalse: #generateIfTrueIfFalseAsArgument:on:indent:
- #ifFalse:ifTrue: #generateIfFalseIfTrueAsArgument:on:indent:
- #cCode: #generateInlineCCodeAsArgument:on:indent:
- #cCode:inSmalltalk: #generateInlineCCodeAsArgument:on:indent:
- ).
-
- asArgumentTranslationDict := Dictionary new: 8.
- 1 to: pairs size by: 2 do: [:i |
- asArgumentTranslationDict at: (pairs at: i) put: (pairs at: i + 1)].
-
- cCodeTranslationDict := Dictionary new: 8.
- pairs := #(
- 'fprintf(stderr, "\n%s: %s", moduleName, s)' 'console.log(moduleName + ": " + s)'
- 'interpreterProxy->majorVersion() == VM_PROXY_MAJOR' 'interpreterProxy.majorVersion() == VM_PROXY_MAJOR'
- 'interpreterProxy->minorVersion() >= VM_PROXY_MINOR' 'interpreterProxy.minorVersion() >= VM_PROXY_MINOR'
- 'rand()' 'Math.random()'
- '*src++' 'src[_src++]'
- '*dst++ = max' 'dst[_dst++] = max'
- 'src++' '_src++'
- '*dst++ = *src; src += 2' 'dst[_dst++] = src[_src]; _src += 2'
- 'tX' 'tX'
- 'tY' 'tY'
- ).
- 1 to: pairs size by: 2 do: [:i |
- cCodeTranslationDict at: (pairs at: i) put: (pairs at: i + 1)].
- !
Item was added:
+ ----- Method: JSCodeGenerator>>initializeJSTranslationDictionary (in category 'JS translation') -----
+ initializeJSTranslationDictionary
+ "Initialize the dictionary mapping message names to actions for JS code generation."
+
+ | pairs |
+ translationDict := Dictionary new: 200.
+ pairs := #(
+ #& #generateAnd:on:indent:
+ #| #generateOr:on:indent:
+ #and: #generateSequentialAnd:on:indent:
+ #or: #generateSequentialOr:on:indent:
+ #not #generateNot:on:indent:
+
+ #+ #generatePlus:on:indent:
+ #- #generateMinus:on:indent:
+ #negated #generateNegated:on:indent:
+ #abs #generateMath:on:indent:
+ #sqrt #generateMath:on:indent:
+ #sin #generateMath:on:indent:
+ #cos #generateMath:on:indent:
+ #tan #generateMath:on:indent:
+ #atan #generateMath:on:indent:
+ #exp #generateMath:on:indent:
+ #log #generateMath:on:indent:
+ #* #generateTimes:on:indent:
+ #/ #generateDivide:on:indent:
+ #// #generateDivide:on:indent:
+ #\\ #generateModulo:on:indent:
+ #<< #generateShiftLeft:on:indent:
+ #>> #generateShiftRight:on:indent:
+ #min: #generateMin:on:indent:
+ #max: #generateMax:on:indent:
+ #between:and: #generateBetweenAnd:on:indent:
+
+ #bitAnd: #generateBitAnd:on:indent:
+ #bitOr: #generateBitOr:on:indent:
+ #bitXor: #generateBitXor:on:indent:
+ #bitShift: #generateBitShift:on:indent:
+ #signedBitShift: #generateSignedBitShift:on:indent:
+ #bitInvert32 #generateBitInvert32:on:indent:
+ #bitClear: #generateBitClear:on:indent:
+
+ #< #generateLessThan:on:indent:
+ #<= #generateLessThanOrEqual:on:indent:
+ #= #generateEqual:on:indent:
+ #> #generateGreaterThan:on:indent:
+ #>= #generateGreaterThanOrEqual:on:indent:
+ #~= #generateNotEqual:on:indent:
+ #== #generateEqual:on:indent:
+ #~~ #generateNotEqual:on:indent:
+ #isNil #generateIsNil:on:indent:
+ #notNil #generateNotNil:on:indent:
+
+ #whileTrue: #generateWhileTrue:on:indent:
+ #whileFalse: #generateWhileFalse:on:indent:
+ #whileTrue #generateDoWhileTrue:on:indent:
+ #whileFalse #generateDoWhileFalse:on:indent:
+ #to:do: #generateToDo:on:indent:
+ #to:by:do: #generateToByDo:on:indent:
+ #repeat #generateRepeat:on:indent:
+
+ #ifTrue: #generateIfTrue:on:indent:
+ #ifFalse: #generateIfFalse:on:indent:
+ #ifTrue:ifFalse: #generateIfTrueIfFalse:on:indent:
+ #ifFalse:ifTrue: #generateIfFalseIfTrue:on:indent:
+
+ #at: #generateAt:on:indent:
+ #at:put: #generateAtPut:on:indent:
+ #basicAt: #generateAt:on:indent:
+ #basicAt:put: #generateAtPut:on:indent:
+
+ #integerValueOf: #generateIntegerValueOf:on:indent:
+ #integerObjectOf: #generateIntegerObjectOf:on:indent:
+ #isIntegerObject: #generateIsIntegerObject:on:indent:
+ #cCode: #generateInlineCCode:on:indent:
+ #cCode:inSmalltalk: #generateInlineCCode:on:indent:
+ #cPreprocessorDirective: #generateInlineCPreprocessorDirective:on:indent:
+ #preprocessorExpression: #generateInlineCppDirective:on:indent:
+ #isDefined:inSmalltalk:comment:ifTrue: #generateInlineCppIfDef:on:indent:
+ #isDefined:inSmalltalk:comment:ifTrue:ifFalse: #generateInlineCppIfDefElse:on:indent:
+ #isDefinedTrueExpression:inSmalltalk:comment:ifTrue:ifFalse: #generateInlineCppIfElse:on:indent:
+ #cCoerce:to: #generateCCoercion:on:indent:
+ #cCoerceSimple:to: #generateCCoercion:on:indent:
+ #addressOf: #generateAddressOf:on:indent:
+ #signedIntFromLong #generateSignedIntFromLong:on:indent:
+ #signedIntToLong #generateSignedIntToLong:on:indent:
+ #signedIntFromShort #generateSignedIntFromShort:on:indent:
+ #signedIntToShort #generateSignedIntToShort:on:indent:
+ #preIncrement #generatePreIncrement:on:indent:
+ #preDecrement #generatePreDecrement:on:indent:
+ #inline: #generateInlineDirective:on:indent:
+ #asFloat #generateAsFloat:on:indent:
+ #asInteger #generateAsInteger:on:indent:
+ #asUnsignedInteger #generateAsUnsignedInteger:on:indent:
+ #asSymbol #generateAsSymbol:on:indent:
+ #anyMask: #generateBitAnd:on:indent:
+ #raisedTo: #generateRaisedTo:on:indent:
+ #touch: #generateTouch:on:indent:
+ #bytesPerWord #generateBytesPerWord:on:indent:
+ #baseHeaderSize #generateBaseHeaderSize:on:indent:
+
+ #sharedCodeNamed:inCase: #generateSharedCodeDirective:on:indent:
+
+ #perform: #generatePerform:on:indent:
+ #perform:with: #generatePerform:on:indent:
+ #perform:with:with: #generatePerform:on:indent:
+ #perform:with:with:with: #generatePerform:on:indent:
+ #perform:with:with:with:with: #generatePerform:on:indent:
+ #perform:with:with:with:with:with: #generatePerform:on:indent:
+
+ #shouldNotImplement #generateSmalltalkMetaError:on:indent:
+ #shouldBeImplemented #generateSmalltalkMetaError:on:indent:
+
+ "optimized interpreterProxy calls"
+ #firstIndexableField: #generateFirstIndexableField:on:indent:
+ #slotSizeOf: #generateSlotSizeOf:on:indent:
+ #stSizeOf: #generateSlotSizeOf:on:indent:
+ #byteSizeOfBytes: #generateByteSizeOf:on:indent:
+ #byteSizeOf: #generateByteSizeOf:on:indent:
+ #fetchClassOf: #generateFetchClassOf:on:indent:
+ #superclassOf: #generateSuperclassOf:on:indent:
+ #instanceSizeOf: #generateInstanceSizeOf:on:indent:
+ #is:KindOf: #generateIsKindOf:on:indent:
+ #isFloatObject: #generateIsFloatObject:on:indent:
+ #cDigitCopyFrom:to:len: #generateCDigitCopy:on:indent:
+ #sizeOfSTArrayFromCPrimitive: #generateSizeOfSTArrayFromCPrimitive:on:indent:
+ #asciiValue #generateIdentityUnary:on:indent:
+ #primitiveFail #generateInterpreterProxyCall:on:indent:
+ #intAtPointer: #generateIntAtPointer:on:indent:
+ #byteAtPointer: #generateByteAtPointer:on:indent:
+ #oopForPointer: #generateOopForPointer:on:indent:
+ #long32At: #generateLong32At:on:indent:
+ #srcLongAt: #generateSrcLongAt:on:indent:
+ #dstLongAt: #generateDstLongAt:on:indent:
+ #dstLongAt:put: #generateDstLongAtPut:on:indent:
+ ).
+
+ 1 to: pairs size by: 2 do: [:i |
+ translationDict at: (pairs at: i) put: (pairs at: i + 1)].
+
+ pairs := #(
+ #ifTrue: #generateIfTrueAsArgument:on:indent:
+ #ifFalse: #generateIfFalseAsArgument:on:indent:
+ #ifTrue:ifFalse: #generateIfTrueIfFalseAsArgument:on:indent:
+ #ifFalse:ifTrue: #generateIfFalseIfTrueAsArgument:on:indent:
+ #cCode: #generateInlineCCodeAsArgument:on:indent:
+ #cCode:inSmalltalk: #generateInlineCCodeAsArgument:on:indent:
+ ).
+
+ asArgumentTranslationDict := Dictionary new: 8.
+ 1 to: pairs size by: 2 do: [:i |
+ asArgumentTranslationDict at: (pairs at: i) put: (pairs at: i + 1)].
+
+ cCodeTranslationDict := Dictionary new: 8.
+ pairs := #(
+ 'fprintf(stderr, "\n%s: %s", moduleName, s)' 'console.log(moduleName + ": " + s)'
+ 'interpreterProxy->majorVersion() == VM_PROXY_MAJOR' 'interpreterProxy.majorVersion() == VM_PROXY_MAJOR'
+ 'interpreterProxy->minorVersion() >= VM_PROXY_MINOR' 'interpreterProxy.minorVersion() >= VM_PROXY_MINOR'
+ 'rand()' 'Math.random()'
+ '*src++' 'src[_src++]'
+ '*dst++ = max' 'dst[_dst++] = max'
+ 'src++' '_src++'
+ '*dst++ = *src; src += 2' 'dst[_dst++] = src[_src]; _src += 2'
+ 'tX' 'tX'
+ 'tY' 'tY'
+ '((sqInt (*)(sqInt, sqInt, sqInt))copyBitsFn)(x0, x1, yValue)' 'copyBitsFn(x0, x1, yValue)'
+ '((sqInt (*)(sqInt))loadBBFn)(bbObj)' 'loadBBFn(bbObj)'
+ ).
+ 1 to: pairs size by: 2 do: [:i |
+ cCodeTranslationDict at: (pairs at: i) put: (pairs at: i + 1)].
+ !
Item was changed:
----- Method: JSCodeGenerator>>isPointer: (in category 'private') -----
isPointer: node
+ self ifPointerVar: node then: [:type | ^true].
- node isVariable ifFalse: [^false].
- (self typeOfVariable: node name) ifNotNil: [:type | ^type includes: $*].
^false!
Item was changed:
----- Method: JSMethod>>emitJSCodeOn:generator: (in category 'JS code generation') -----
emitJSCodeOn: aStream generator: aCodeGen
"Emit JS code for this method onto the given stream. All calls to inlined methods should already have been expanded."
aCodeGen currentMethod: self.
aCodeGen pushScope: declarations while: [
self emitJSCommentOn: aStream. "place method comment before function"
self emitJSHeaderOn: aStream generator: aCodeGen.
+ (self emitJSSpecialOn: aStream level: 1 generator: aCodeGen)
+ ifFalse: [parseTree emitJSCodeOn: aStream level: 1 generator: aCodeGen].
- parseTree emitJSCodeOn: aStream level: 1 generator: aCodeGen.
aStream nextPutAll: '}'; cr]!
Item was added:
+ ----- Method: JSMethod>>emitJSSpecialOn:level:generator: (in category 'JS hacks') -----
+ emitJSSpecialOn: aStream level: level generator: aCodeGen
+ | expr type |
+ aCodeGen pluginName = 'B2DPlugin' ifFalse: [^false].
+ (returnType includes: $*) ifFalse: [^false].
+ parseTree statements first isReturn ifFalse: [^false].
+ expr := parseTree statements first expression.
+ expr isSend ifFalse: [^false].
+ type := returnType.
+ expr selector = #cCoerce:to: ifTrue: [
+ type = expr args second value ifFalse: [self halt].
+ expr := expr args first.
+ ].
+ expr selector = #+ ifFalse: [^false].
+ aStream tab: level; nextPutAll: 'return '.
+ expr emitJSPointerArithmetic: type on: aStream level: level generator: aCodeGen type: type top: true.
+ aStream nextPutAll: ';'; cr.
+ ^true
+ !
Item was changed:
----- Method: JSPluginCodeGenerator>>ignoredMethods (in category 'public') -----
ignoredMethods
pluginName = 'BitBltPlugin' ifTrue: [
^#(dstLongAt: dstLongAt:put: srcLongAt:)].
pluginName = 'ScratchPlugin' ifTrue: [
^(ScratchPlugin organization listAtCategoryNamed: 'serial port'),
(ScratchPlugin organization listAtCategoryNamed: 'os functions')].
+ pluginName = 'B2DPlugin' ifTrue: [
+ ^self translatedMethodsB2DPlugin collect: [:ea | ea key]].
^super ignoredMethods!
Item was added:
+ ----- Method: JSPluginCodeGenerator>>overrideJSTranslationDictionary (in category 'public') -----
+ overrideJSTranslationDictionary
+ | sel |
+ sel := (#translatedMethods, self pluginName) asSymbol.
+ (self respondsTo: sel) ifFalse: [^self].
+ (self perform: sel) associationsDo: [:assoc |
+ translationDict at: assoc key put: assoc value].
+ !
Item was changed:
----- Method: JSPluginCodeGenerator>>pluginName: (in category 'public') -----
pluginName: aString
"TPR - moved from JSCodeGenerator"
"Set the plugin name when generating plugins."
+ pluginName := aString.
+ self overrideJSTranslationDictionary.!
- pluginName := aString.!
Item was added:
+ ----- Method: JSPluginCodeGenerator>>translatedMethodsB2DPlugin (in category 'public') -----
+ translatedMethodsB2DPlugin
+ "see senders of translatedMethods"
+ ^{
+ #makeUnsignedFrom: -> #generateMakeUnsignedFrom:on:indent:.
+ #loadPointIntAt:from: -> #generateLoadPointInt:on:indent:.
+ #loadPointShortAt:from: -> #generateLoadPointShort:on:indent:.
+ }!
Item was removed:
- ----- Method: JSSmartSyntaxPluginCodeGenerator>>initializeCTranslationDictionary (in category 'translating builtins') -----
- initializeCTranslationDictionary
- "Initialize the dictionary mapping message names to actions for C code generation."
-
- | pairs |
- super initializeCTranslationDictionary.
- pairs := #(
- #asCInt #generateAsCInt:on:indent:
- #asCUnsigned #generateAsCUnsigned:on:indent:
- #asCBoolean #generateAsCBoolean:on:indent:
- #asCDouble #generateAsCDouble:on:indent:
-
- #asSmallIntegerObj #generateAsSmallIntegerObj:on:indent:
- #asPositiveIntegerObj #generateAsPositiveIntegerObj:on:indent:
- #asBooleanObj #generateAsBooleanObj:on:indent:
- #asFloatObj #generateAsFloatObj:on:indent:
-
- #asIf:var: #generateAsIfVar:on:indent:
- #asIf:var:asValue: #generateAsIfVarAsValue:on:indent:
- #asIf:var:put: #generateAsIfVarPut:on:indent:
- #field: #generateField:on:indent:
- #field:put: #generateFieldPut:on:indent:
-
- #class #generateClass:on:indent:
-
- #stSize #generateStSize:on:indent:
- #stAt: #generateStAt:on:indent:
- #stAt:put: #generateStAtPut:on:indent:
-
- #asCharPtr #generateAsCharPtr:on:indent:
- #asIntPtr #generateAsIntPtr:on:indent:
- #cPtrAsOop #generateCPtrAsOop:on:indent:
- #next #generateNext:on:indent:
-
- #asOop: #generateAsOop:on:indent:
- #asValue: #generateAsValue:on:indent:
-
- #isFloat #generateIsFloat:on:indent:
- #isIndexable #generateIsIndexable:on:indent:
- #isIntegerOop #generateIsIntegerOop:on:indent:
- #isIntegerValue #generateIsIntegerValue:on:indent:
- #FloatOop #generateIsFloatValue:on:indent:
- #isWords #generateIsWords:on:indent:
- #isWordsOrBytes #generateIsWordsOrBytes:on:indent:
- #isPointers #generateIsPointers:on:indent:
- #isNil #generateIsNil:on:indent:
- #isMemberOf: #generateIsMemberOf:on:indent:
- #isKindOf: #generateIsKindOf:on:indent:
-
- #fromStack: #generateFromStack:on:indent:
- #clone #generateClone:on:indent
- #new #generateNew:on:indent
- #new: #generateNewSize:on:indent
- #superclass #generateSuperclass:on:indent:
- #remapOop:in: #generateRemapOopIn:on:indent:
- #debugCode: #generateDebugCode:on:indent:
- ).
-
- 1 to: pairs size by: 2 do: [:i |
- translationDict at: (pairs at: i) put: (pairs at: i + 1)].
- !
Item was added:
+ ----- Method: JSSmartSyntaxPluginCodeGenerator>>initializeJSTranslationDictionary (in category 'translating builtins') -----
+ initializeJSTranslationDictionary
+ "Initialize the dictionary mapping message names to actions for C code generation."
+
+ | pairs |
+ super initializeJSTranslationDictionary.
+ pairs := #(
+ #asCInt #generateAsCInt:on:indent:
+ #asCUnsigned #generateAsCUnsigned:on:indent:
+ #asCBoolean #generateAsCBoolean:on:indent:
+ #asCDouble #generateAsCDouble:on:indent:
+
+ #asSmallIntegerObj #generateAsSmallIntegerObj:on:indent:
+ #asPositiveIntegerObj #generateAsPositiveIntegerObj:on:indent:
+ #asBooleanObj #generateAsBooleanObj:on:indent:
+ #asFloatObj #generateAsFloatObj:on:indent:
+
+ #asIf:var: #generateAsIfVar:on:indent:
+ #asIf:var:asValue: #generateAsIfVarAsValue:on:indent:
+ #asIf:var:put: #generateAsIfVarPut:on:indent:
+ #field: #generateField:on:indent:
+ #field:put: #generateFieldPut:on:indent:
+
+ #class #generateClass:on:indent:
+
+ #stSize #generateStSize:on:indent:
+ #stAt: #generateStAt:on:indent:
+ #stAt:put: #generateStAtPut:on:indent:
+
+ #asCharPtr #generateAsCharPtr:on:indent:
+ #asIntPtr #generateAsIntPtr:on:indent:
+ #cPtrAsOop #generateCPtrAsOop:on:indent:
+ #next #generateNext:on:indent:
+
+ #asOop: #generateAsOop:on:indent:
+ #asValue: #generateAsValue:on:indent:
+
+ #isFloat #generateIsFloat:on:indent:
+ #isIndexable #generateIsIndexable:on:indent:
+ #isIntegerOop #generateIsIntegerOop:on:indent:
+ #isIntegerValue #generateIsIntegerValue:on:indent:
+ #FloatOop #generateIsFloatValue:on:indent:
+ #isWords #generateIsWords:on:indent:
+ #isWordsOrBytes #generateIsWordsOrBytes:on:indent:
+ #isPointers #generateIsPointers:on:indent:
+ #isNil #generateIsNil:on:indent:
+ #isMemberOf: #generateIsMemberOf:on:indent:
+ #isKindOf: #generateIsKindOf:on:indent:
+
+ #fromStack: #generateFromStack:on:indent:
+ #clone #generateClone:on:indent
+ #new #generateNew:on:indent
+ #new: #generateNewSize:on:indent
+ #superclass #generateSuperclass:on:indent:
+ #remapOop:in: #generateRemapOopIn:on:indent:
+ #debugCode: #generateDebugCode:on:indent:
+ ).
+
+ 1 to: pairs size by: 2 do: [:i |
+ translationDict at: (pairs at: i) put: (pairs at: i + 1)].
+ !
Item was changed:
----- Method: TAssignmentNode>>emitJSCodeOn:level:generator: (in category '*vmmakerjs') -----
emitJSCodeOn: aStream level: level generator: aCodeGen
expression isSwitch ifTrue:
[^expression emitJSCodeOn: aStream addToEndOfCases: self level: level generator: aCodeGen].
+ (self isVariableUpdatingAssignment and: [(aCodeGen isPointer: variable) not])
- self isVariableUpdatingAssignment
ifTrue:
[(expression args first isConstant and: [expression args first value = 1])
ifTrue: [aStream nextPutAll: expression selector, expression selector.
variable emitJSCodeOn: aStream level: level generator: aCodeGen]
ifFalse: [
variable emitJSCodeOn: aStream level: level generator: aCodeGen.
aStream nextPutAll: ' ', expression selector, '= '.
expression args first emitJSCodeAsArgumentOn: aStream level: level generator: aCodeGen]]
ifFalse:
[ | coerceToInt |
coerceToInt := (variable isFloatIn: aCodeGen) not and: [expression isFloatIn: aCodeGen].
variable emitJSCodeOn: aStream level: level generator: aCodeGen.
aStream nextPutAll: ' = '.
expression emitJSCodeAsArgumentOn: aStream level: level generator: aCodeGen.
coerceToInt ifTrue: [aStream nextPutAll: '|0'].]!
Item was added:
+ ----- Method: TSendNode>>emitJSPointerArithmetic:on:level:generator:type:top: (in category '*vmmakerjs') -----
+ emitJSPointerArithmetic: type on: aStream level: level generator: aGenerator type: cType top: top
+ (selector = #+) ifFalse: [self halt].
+ receiver isVariable
+ ifTrue: [ | typeAndSize |
+ typeAndSize := ({'int' -> #('Int32Array' 4). 'float' -> #('Float32Array' 4)} as: Dictionary)
+ at: ((cType copyUpTo: $*) copyWithout: $ ).
+ aStream nextPutAll: ('new {1}({2}.buffer, {2}.byteOffset + {3} * ('
+ format: {typeAndSize first. receiver name. typeAndSize second})]
+ ifFalse: [receiver emitJSPointerArithmetic: type on: aStream level: level generator: aGenerator type: cType top: false.
+ aStream nextPutAll: ' + '].
+ aGenerator emitJSExpression: arguments first on: aStream.
+ top ifTrue: [aStream nextPutAll: '))'].!
1
0
Re: [Pharo-dev] How to check whether the handle is always valid with NativeBoost ?
by Eliot Miranda 13 Nov '14
by Eliot Miranda 13 Nov '14
13 Nov '14
Hi Vincent,
one way, used in VisualWorks, is to ensure that only valid handles
exist. So very early at startup the system does some allInstances
invocations on the classes of handles and invalidates all the handles
found. This doesn't fix handles stored as raw integers anywhere, but
provided the system is designed to have specific objects for external
handles (and I hope it is) this shouldn't happen.
Since snapshot is relatively rare and start-up relatively frequent (at
least in e.g. a web deployment context), one performance improvement is to
do the allInstances before snapshot, and then merely enumerate the
collection of handles, rather than use allInstances.
On Thu, Nov 13, 2014 at 9:05 AM, Blondeau Vincent <
vincent.blondeau(a)worldline.com> wrote:
> Hi !
>
>
>
> I am doing a binding to the R library with NativeBoost.
>
> So I create some external objects and apply some functions on them.
>
>
>
> If the handle to the object is not valid, either the function crashes or
> gives a bad result.
>
>
>
> How can I ensure to have a valid pointer at anytime ?
>
>
>
> I see two solutions:
>
> - Either check at any NativeBoost call that the handle is valid
> (by checking the session id)
>
> - Or do a proxy that checks the session and recreate the
> external object.
>
>
>
> What do you think ?
>
>
>
> Thanks in advance,
>
>
>
> Cheers,
>
> Vincent BLONDEAU
>
>
>
> ------------------------------
>
> Ce message et les pièces jointes sont confidentiels et réservés à l'usage
> exclusif de ses destinataires. Il peut également être protégé par le secret
> professionnel. Si vous recevez ce message par erreur, merci d'en avertir
> immédiatement l'expéditeur et de le détruire. L'intégrité du message ne
> pouvant être assurée sur Internet, la responsabilité de Worldline ne pourra
> être recherchée quant au contenu de ce message. Bien que les meilleurs
> efforts soient faits pour maintenir cette transmission exempte de tout
> virus, l'expéditeur ne donne aucune garantie à cet égard et sa
> responsabilité ne saurait être recherchée pour tout dommage résultant d'un
> virus transmis.
>
> This e-mail and the documents attached are confidential and intended
> solely for the addressee; it may also be privileged. If you receive this
> e-mail in error, please notify the sender immediately and destroy it. As
> its integrity cannot be secured on the Internet, the Worldline liability
> cannot be triggered for the message content. Although the sender endeavours
> to maintain a computer virus-free network, the sender does not warrant that
> this transmission is virus-free and will not be liable for any damages
> resulting from any virus transmitted.
>
--
best,
Eliot
2
1
[commit][3131] Merge Levente' s recent changes to DNS lookup on Windows and SSL on Unix.
by commitsï¼ squeakvm.org 13 Nov '14
by commitsï¼ squeakvm.org 13 Nov '14
13 Nov '14
Revision: 3131
Author: eliot
Date: 2014-11-13 14:36:48 -0800 (Thu, 13 Nov 2014)
Log Message:
-----------
Merge Levente's recent changes to DNS lookup on Windows and SSL on Unix.
Don't forget the SSL changes in plugins/Cross.
See http://squeakvm.org/cgi-bin/viewvc.cgi/squeak?view=revision&revision=2249
http://bugs.squeak.org/view.php?id=7824
Modified Paths:
--------------
trunk/platforms/Cross/plugins/SqueakSSL/SqueakSSL.h
Property Changed:
----------------
trunk/platforms/Cross/plugins/sqPluginsSCCSVersion.h
Modified: trunk/platforms/Cross/plugins/SqueakSSL/SqueakSSL.h
===================================================================
--- trunk/platforms/Cross/plugins/SqueakSSL/SqueakSSL.h 2014-11-12 19:52:35 UTC (rev 3130)
+++ trunk/platforms/Cross/plugins/SqueakSSL/SqueakSSL.h 2014-11-13 22:36:48 UTC (rev 3131)
@@ -48,6 +48,7 @@
/**********************************************/
#define SQSSL_PROP_PEERNAME 0
#define SQSSL_PROP_CERTNAME 1
+#define SQSSL_PROP_SERVERNAME 2
/* sqCreateSSL: Creates a new SSL instance.
Arguments: None.
Property changes on: trunk/platforms/Cross/plugins/sqPluginsSCCSVersion.h
___________________________________________________________________
Modified: checkindate
- Fri Oct 24 21:40:19 PDT 2014
+ Thu Nov 13 14:36:11 PST 2014
1
0
Eliot Miranda uploaded a new version of VMMaker to project VM Maker:
http://source.squeak.org/VMMaker/VMMaker.oscog-eem.924.mcz
==================== Summary ====================
Name: VMMaker.oscog-eem.924
Author: eem
Time: 13 November 2014, 2:16:34.626 pm
UUID: 911b0856-1686-43f8-b8cf-275a4dfd4968
Ancestors: VMMaker.oscog-eem.923
Simulator/Slang:
Refactor to allow 32-bit and 64-bit Spur to coexist
in the simulator, thereby allowing a 64-bit bootstrap.
Replace direct use of BytesPerWord, ShiftForWord,
BytesPerOop, and BaseHeaderSize with sends of
wordSize, shiftForWord, bytesPerOop and
baseHeaderSize respectively.
Make sure these are still output as the manifest
constants in the generated C. Eliminate use of
bytesPerSlot in favour of bytesPerOop. The use of
sends is similar to those in trunk VMMaker, but I
don't have time to merge. Sorry :-(.
Work-around use of sends for bytesPerOop in e.g.
generateToByDo:on:indent: and users of
isConstantNode:valueInto:.
Do a better job at inlining via
inlineCodeOrNilForStatement:in:. Comment in
isNode:substitutableFor:inMethod:in: explains.
Eliminate generic VM_LABEL support, labelling only
the bytecodes in interpret.
Eliminate use of LargeContextSize in the stack and
cog VMs. Alas haven't yet eliminated the frame
offset constants such as FoxCallerSavedIP et al.
We only need one of the two word sizes of
interpreter to be executable in the bootstrap.
=============== Diff against VMMaker.oscog-eem.923 ===============
Item was changed:
----- Method: BlockNode>>isPotentialCCaseLabel:in: (in category '*VMMaker-C translation') -----
isPotentialCCaseLabel: stmt in: aTMethod
(stmt isVariableNode
or: [stmt isLiteralNode
and: [stmt isConstantNumber or: [stmt literalValue isSymbol]]]) ifTrue:
[^true].
stmt isMessageNode ifTrue:
+ [| selector implementingClass method |
- [| selector method |
selector := stmt selector key.
(#(* + -) includes: selector) ifTrue:
[^(self isPotentialCCaseLabel: stmt receiver in: aTMethod)
and: [self isPotentialCCaseLabel: stmt arguments first in: aTMethod]].
(selector = #asSymbol
and: [stmt receiver isLiteralNode
and: [stmt receiver literalValue isSymbol]]) ifTrue:
[^true].
(stmt arguments isEmpty
+ and: [implementingClass := aTMethod definingClass whichClassIncludesSelector: selector.
+ implementingClass ifNil:
+ [implementingClass := aTMethod definingClass objectMemoryClass whichClassIncludesSelector: selector].
+ method := implementingClass >> selector.
- and: [method := (aTMethod definingClass whichClassIncludesSelector: selector) >> selector.
(method isQuick
or: [(method literalAt: 1) isInteger
and: [method numLiterals = 3]])
+ and: [(implementingClass basicNew perform: selector) isInteger]]) ifTrue:
- and: [(aTMethod definingClass basicNew perform: selector) isInteger]]) ifTrue:
[^true]].
^false!
Item was changed:
----- Method: CCodeGenerator>>collectInlineList: (in category 'inlining') -----
collectInlineList: inlineFlagOrSymbol
"Make a list of methods that should be inlined. If inlineFlagOrSymbol == #asSpecified
only inline methods marked with <inline: true>."
"Details: The method must not include any inline C, since the
translator cannot currently map variable names in inlined C code.
Methods to be inlined must be small or called from only one place."
| selectorsOfMethodsNotToInline callsOf |
self assert: (#(true false asSpecified) includes: inlineFlagOrSymbol).
selectorsOfMethodsNotToInline := Set new: methods size.
selectorsOfMethodsNotToInline addAll: macros keys.
apiMethods ifNotNil:
[selectorsOfMethodsNotToInline addAll: apiMethods keys].
methods do:
[:m|
m isStructAccessor ifTrue:
[selectorsOfMethodsNotToInline add: m selector]].
"build dictionary to record the number of calls to each method"
callsOf := Dictionary new: methods size * 2.
methods keysAndValuesDo:
[:s :m|
+ (m isRealMethod
+ and: [self shouldGenerateMethod: m]) ifTrue:
+ [callsOf at: s put: 0]].
- m isRealMethod ifTrue: [callsOf at: s put: 0]].
"For each method, scan its parse tree once or twice to:
1. determine if the method contains unrenamable C code or declarations or has a C builtin
2. determine how many nodes it has
3. increment the sender counts of the methods it calls"
inlineList := Set new: methods size * 2.
(methods reject: [:m| selectorsOfMethodsNotToInline includes: m selector]) do:
[:m| | inlineIt hasUnrenamableCCode nodeCount |
breakSrcInlineSelector = m selector ifTrue:
[self halt].
inlineIt := #dontCare.
(translationDict includesKey: m selector)
ifTrue: [hasUnrenamableCCode := true]
ifFalse:
[hasUnrenamableCCode := m hasUnrenamableCCode.
nodeCount := 0.
m parseTree nodesDo:
[:node|
node isSend ifTrue:
[callsOf
at: node selector
ifPresent:
[:senderCount| callsOf at: node selector put: senderCount + 1]].
nodeCount := nodeCount + 1].
inlineIt := m extractInlineDirective]. "may be true, false, or #dontCare"
(hasUnrenamableCCode or: [inlineIt == false])
ifTrue: "don't inline if method has C code or contains negative inline directive"
[inlineIt == true ifTrue:
[logger
ensureCr;
nextPutAll: 'failed to inline ';
nextPutAll: m selector;
nextPutAll: ' as it contains unrenamable C declarations or C code';
cr; flush].
selectorsOfMethodsNotToInline add: m selector]
ifFalse:
[(inlineFlagOrSymbol == #asSpecified
ifTrue: [inlineIt == true]
ifFalse: [nodeCount < 40 or: [inlineIt == true]]) ifTrue:
"inline if method has no C code and is either small or contains inline directive"
[inlineList add: m selector]]].
inlineFlagOrSymbol ~~ #asSpecified ifTrue:
[callsOf associationsDo:
[:assoc|
(assoc value = 1
and: [(selectorsOfMethodsNotToInline includes: assoc key) not]) ifTrue:
[inlineList add: assoc key]]]!
Item was changed:
----- Method: CCodeGenerator>>emitCExpression:on:indent: (in category 'C code generator') -----
emitCExpression: aParseNode on: aStream indent: level
"Emit C code for the expression described by the given parse node."
(aParseNode isLeaf
or: [aParseNode isSend
+ and: [#(bytesPerOop bytesPerWord baseHeaderSize wordSize) includes: aParseNode selector]])
- and: [#(bytesPerOop bytesPerWord baseHeaderSize) includes: aParseNode selector]])
ifTrue:
["omit parens"
aParseNode emitCCodeAsExpressionOn: aStream level: level generator: self]
ifFalse:
[aStream nextPut: $(.
aParseNode emitCCodeAsExpressionOn: aStream level: level generator: self.
aStream nextPut: $)]!
Item was changed:
----- Method: CCodeGenerator>>emitCFunctionPrototypes:on: (in category 'C code generator') -----
emitCFunctionPrototypes: methodList on: aStream
"Store prototype declarations for all non-inlined methods on the given stream."
| exporting |
aStream cr; nextPutAll: '/*** Function Prototypes ***/'; cr.
"Hmm, this should be in the sqConfig.h files. For now put it here..."
"Feel free to add equivalents for other compilers"
vmClass notNil ifTrue:
[NoRegParmsInAssertVMs ifTrue:
[aStream nextPutAll: '\\#if !!PRODUCTION && defined(__GNUC__) && !!defined(NoDbgRegParms)\# define NoDbgRegParms __attribute__ ((regparm (0)))\#endif' withCRs.
aStream nextPutAll: '\\#if !!defined(NoDbgRegParms)\# define NoDbgRegParms /*empty*/\#endif\\' withCRs].
aStream nextPutAll: '\\#if defined(__GNUC__) && !!defined(NeverInline)\# define NeverInline __attribute__ ((noinline))\#endif' withCRs.
aStream nextPutAll: '\\#if !!defined(NeverInline)\# define NeverInline /*empty*/\#endif\\' withCRs].
exporting := false.
+ (methodList select: [:m| m isRealMethod
+ and: [self shouldGenerateMethod: m]]) do:
- (methodList select: [:m| m isRealMethod]) do:
[:m |
self emitExportPragma ifTrue:
[m export
ifTrue: [exporting ifFalse:
[aStream nextPutAll: '#pragma export on'; cr.
exporting := true]]
ifFalse: [exporting ifTrue:
[aStream nextPutAll: '#pragma export off'; cr.
exporting := false]]].
m emitCFunctionPrototype: aStream generator: self.
(NoRegParmsInAssertVMs and: [vmClass notNil and: [m export not and: [m isStatic and: [m args notEmpty]]]]) ifTrue:
[aStream nextPutAll: ' NoDbgRegParms'].
(vmClass notNil and: [m inline == #never]) ifTrue:
[aStream nextPutAll: ' NeverInline'].
aStream nextPut: $; ; cr].
exporting ifTrue: [aStream nextPutAll: '#pragma export off'; cr].
aStream cr!
Item was changed:
----- Method: CCodeGenerator>>emitCMethods:on: (in category 'C code generator') -----
emitCMethods: methodList on: aStream
'Writing Translated Code...'
displayProgressAt: Sensor cursorPoint
from: 0 to: methods size
during:
[:bar |
methodList doWithIndex:
[ :m :i |
bar value: i.
+ (m isRealMethod
+ and: [self shouldGenerateMethod: m]) ifTrue:
- m isRealMethod ifTrue:
[m emitCCodeOn: aStream generator: self]]]!
Item was changed:
----- Method: CCodeGenerator>>generateToByDo:on:indent: (in category 'C translation') -----
generateToByDo: msgNode on: aStream indent: level
"Generate the C code for this message onto the given stream."
"N.B. MessageNode>>asTranslatorNodeIn: adds the limit var as a hidden fourth argument."
+ | blockExpr iterationVar limitExpr mayHaveSideEffects limitVar step |
- | blockExpr iterationVar limitExpr mayHaveSideEffects limitVar step negative |
blockExpr := msgNode args third.
blockExpr args size = 1 ifFalse:
[self error: 'wrong number of block arguments'].
iterationVar := blockExpr args first.
limitExpr := msgNode args first.
aStream nextPutAll: 'for (', iterationVar, ' = '.
self emitCExpression: msgNode receiver on: aStream.
mayHaveSideEffects := msgNode args size = 4. "See TMethod>>prepareMethodIn:"
mayHaveSideEffects ifTrue:
[limitVar := msgNode args last.
aStream nextPutAll: ', ', limitVar name, ' = '.
self emitCExpression: limitExpr on: aStream.
limitExpr := limitVar].
aStream nextPutAll: '; ', iterationVar.
+ step := msgNode args at: 2.
+ self generateToByDoLimitExpression: limitExpr
+ negative: (self stepExpressionIsNegative: step)
+ on: aStream.
- negative := ((step := msgNode args at: 2) isConstant and: [step value < 0])
- or: [step isSend and: [step selector == #negated
- and: [step receiver isConstant and: [step receiver value >= 0]]]].
- self generateToByDoLimitExpression: limitExpr negative: negative on: aStream.
aStream nextPutAll: '; ', iterationVar, ' += '.
self emitCExpression: step on: aStream.
aStream nextPutAll: ') {'; cr.
blockExpr emitCCodeOn: aStream level: level + 1 generator: self.
aStream tab: level.
aStream nextPut: $}!
Item was changed:
----- Method: CCodeGenerator>>initializeCTranslationDictionary (in category 'C translation') -----
initializeCTranslationDictionary
"Initialize the dictionary mapping message names to actions for C code generation."
| pairs |
translationDict := Dictionary new: 200.
pairs := #(
#& #generateAnd:on:indent:
#| #generateOr:on:indent:
#and: #generateSequentialAnd:on:indent:
#or: #generateSequentialOr:on:indent:
#not #generateNot:on:indent:
#+ #generatePlus:on:indent:
#- #generateMinus:on:indent:
#negated #generateNegated:on:indent:
#* #generateTimes:on:indent:
#/ #generateDivide:on:indent:
#// #generateDivide:on:indent:
#\\ #generateModulo:on:indent:
#<< #generateShiftLeft:on:indent:
#>> #generateShiftRight:on:indent:
#min: #generateMin:on:indent:
#max: #generateMax:on:indent:
#between:and: #generateBetweenAnd:on:indent:
#bitAnd: #generateBitAnd:on:indent:
#bitOr: #generateBitOr:on:indent:
#bitXor: #generateBitXor:on:indent:
#bitShift: #generateBitShift:on:indent:
#signedBitShift: #generateSignedBitShift:on:indent:
#bitInvert32 #generateBitInvert32:on:indent:
#bitClear: #generateBitClear:on:indent:
#truncateTo: #generateTruncateTo:on:indent:
#rounded #generateRounded:on:indent:
#< #generateLessThan:on:indent:
#<= #generateLessThanOrEqual:on:indent:
#= #generateEqual:on:indent:
#> #generateGreaterThan:on:indent:
#>= #generateGreaterThanOrEqual:on:indent:
#~= #generateNotEqual:on:indent:
#== #generateEqual:on:indent:
#~~ #generateNotEqual:on:indent:
#isNil #generateIsNil:on:indent:
#notNil #generateNotNil:on:indent:
#whileTrue: #generateWhileTrue:on:indent:
#whileFalse: #generateWhileFalse:on:indent:
#whileTrue #generateDoWhileTrue:on:indent:
#whileFalse #generateDoWhileFalse:on:indent:
#to:do: #generateToDo:on:indent:
#to:by:do: #generateToByDo:on:indent:
#repeat #generateRepeat:on:indent:
#ifTrue: #generateIfTrue:on:indent:
#ifFalse: #generateIfFalse:on:indent:
#ifTrue:ifFalse: #generateIfTrueIfFalse:on:indent:
#ifFalse:ifTrue: #generateIfFalseIfTrue:on:indent:
#ifNotNil: #generateIfNotNil:on:indent:
#ifNil: #generateIfNil:on:indent:
#ifNotNil:ifNil: #generateIfNotNilIfNil:on:indent:
#ifNil:ifNotNil: #generateIfNilIfNotNil:on:indent:
#at: #generateAt:on:indent:
#at:put: #generateAtPut:on:indent:
#basicAt: #generateAt:on:indent:
#basicAt:put: #generateAtPut:on:indent:
#integerValueOf: #generateIntegerValueOf:on:indent:
#integerObjectOf: #generateIntegerObjectOf:on:indent:
#isIntegerObject: #generateIsIntegerObject:on:indent:
#cCode: #generateInlineCCode:on:indent:
#cCode:inSmalltalk: #generateInlineCCode:on:indent:
#cPreprocessorDirective: #generateInlineCPreprocessorDirective:on:indent:
#cppIf:ifTrue:ifFalse: #generateInlineCppIfElse:on:indent:
#cppIf:ifTrue: #generateInlineCppIfElse:on:indent:
#cCoerce:to: #generateCCoercion:on:indent:
#cCoerceSimple:to: #generateCCoercion:on:indent:
#addressOf: #generateAddressOf:on:indent:
#addressOf:put: #generateAddressOf:on:indent:
#asAddress:put: #generateAsAddress:on:indent:
#signedIntFromLong #generateSignedIntFromLong:on:indent:
#signedIntToLong #generateSignedIntToLong:on:indent:
#signedIntFromShort #generateSignedIntFromShort:on:indent:
#signedIntToShort #generateSignedIntToShort:on:indent:
#preIncrement #generatePreIncrement:on:indent:
#preDecrement #generatePreDecrement:on:indent:
#inline: #generateInlineDirective:on:indent:
#asFloat #generateAsFloat:on:indent:
#asInteger #generateAsInteger:on:indent:
#asUnsignedInteger #generateAsUnsignedInteger:on:indent:
#asLong #generateAsLong:on:indent:
#asUnsignedLong #generateAsUnsignedLong:on:indent:
#asVoidPointer #generateAsVoidPointer:on:indent:
#asSymbol #generateAsSymbol:on:indent:
#flag: #generateFlag:on:indent:
#anyMask: #generateBitAnd:on:indent:
#noMask: #generateNoMask:on:indent:
#raisedTo: #generateRaisedTo:on:indent:
#touch: #generateTouch:on:indent:
#bytesPerOop #generateBytesPerOop:on:indent:
#bytesPerWord #generateBytesPerWord:on:indent:
+ #wordSize #generateBytesPerWord:on:indent:
#baseHeaderSize #generateBaseHeaderSize:on:indent:
#sharedCodeNamed:inCase: #generateSharedCodeDirective:on:indent:
#perform: #generatePerform:on:indent:
#perform:with: #generatePerform:on:indent:
#perform:with:with: #generatePerform:on:indent:
#perform:with:with:with: #generatePerform:on:indent:
#perform:with:with:with:with: #generatePerform:on:indent:
#perform:with:with:with:with:with: #generatePerform:on:indent:
#value #generateValue:on:indent:
#value: #generateValue:on:indent:
#value:value: #generateValue:on:indent:
#value:value:value: #generateValue:on:indent:
#deny: #generateDeny:on:indent:
#shouldNotImplement #generateSmalltalkMetaError:on:indent:
#shouldBeImplemented #generateSmalltalkMetaError:on:indent:
#subclassResponsibility #generateSmalltalkMetaError:on:indent:
).
1 to: pairs size by: 2 do: [:i |
translationDict at: (pairs at: i) put: (pairs at: i + 1)].
pairs := #(
#ifTrue: #generateIfTrueAsArgument:on:indent:
#ifFalse: #generateIfFalseAsArgument:on:indent:
#ifTrue:ifFalse: #generateIfTrueIfFalseAsArgument:on:indent:
#ifFalse:ifTrue: #generateIfFalseIfTrueAsArgument:on:indent:
#ifNotNil: #generateIfNotNilAsArgument:on:indent:
#ifNil: #generateIfNilAsArgument:on:indent:
#ifNotNil:ifNil: #generateIfNotNilIfNilAsArgument:on:indent:
#ifNil:ifNotNil: #generateIfNilIfNotNilAsArgument:on:indent:
#cCode: #generateInlineCCodeAsArgument:on:indent:
#cCode:inSmalltalk: #generateInlineCCodeAsArgument:on:indent:
#cppIf:ifTrue:ifFalse: #generateInlineCppIfElseAsArgument:on:indent:
#cppIf:ifTrue: #generateInlineCppIfElseAsArgument:on:indent:
#value #generateValueAsArgument:on:indent:
#value: #generateValueAsArgument:on:indent:
#value:value: #generateValueAsArgument:on:indent:
).
asArgumentTranslationDict := Dictionary new: 8.
1 to: pairs size by: 2 do: [:i |
asArgumentTranslationDict at: (pairs at: i) put: (pairs at: i + 1)].
!
Item was changed:
----- Method: CCodeGenerator>>localizeGlobalVariables (in category 'utilities') -----
localizeGlobalVariables
| candidates elected localized |
"find all globals used in only one method"
candidates := globalVariableUsage select: [:e | e size = 1].
(candidates keys select: [:k| vmClass mustBeGlobal: k]) do:
[:k| candidates removeKey: k].
elected := Set new.
localized := Dictionary new. "for an ordered report"
"move any suitable global to be local to the single method using it"
candidates keysAndValuesDo:
[:key :targets |
targets do:
[:name |
(methods at: name ifAbsent: []) ifNotNil:
[:procedure | | newDeclaration |
+ (procedure isRealMethod
+ and: [self shouldGenerateMethod: procedure]) ifTrue:
- procedure isRealMethod ifTrue:
[(localized at: name ifAbsentPut: [SortedCollection new]) add: key.
elected add: (procedure locals add: key).
newDeclaration := variableDeclarations at: key ifAbsent: ['sqInt ', key].
(self initializerForInstVar: key inStartClass: procedure definingClass) ifNotNil:
[:initializerNode|
newDeclaration := String streamContents:
[:s|
s nextPutAll: newDeclaration; nextPutAll: ' = '.
initializerNode emitCCodeOn: s level: 0 generator: self]].
procedure declarationAt: key put: newDeclaration.
variableDeclarations removeKey: key ifAbsent: []]]]].
logger ifNotNil:
[localized keys asSortedCollection do:
[:name|
(localized at: name) do:
[:var|
logger ensureCr; show: var, ' localised to ', name; cr]]].
elected do: [:ea| (variables includes: ea) ifTrue: [self checkDeleteVariable: ea]].
variables removeAllFoundIn: elected!
Item was changed:
----- Method: CCodeGenerator>>mostBasicConstantSelectors (in category 'accessing') -----
mostBasicConstantSelectors
"c.f. VMBasicConstants class>>#mostBasicConstantNames"
+ ^#(baseHeaderSize bytesPerOop bytesPerWord wordSize)!
- ^#(baseHeaderSize bytesPerOop bytesPerWord)!
Item was changed:
----- Method: CCodeGenerator>>outputAsmLabel:on: (in category 'utilities') -----
outputAsmLabel: selector on: aStream
| count |
suppressAsmLabels ifTrue: [^self].
+ asmLabelCounts ifNil:
- asmLabelCounts isNil ifTrue:
[asmLabelCounts := Dictionary new].
count := asmLabelCounts
at: selector
put: 1 + (asmLabelCounts at: selector ifAbsent: [-1]).
aStream
nextPutAll: 'VM_LABEL(';
- print: count;
nextPutAll: (self cFunctionNameFor: selector);
+ nextPutAll: (count = 0 ifTrue: [''] ifFalse: [count printString]);
nextPut: $);
nextPut: $;!
Item was changed:
----- Method: CCodeGenerator>>pruneUnreachableMethods (in category 'inlining') -----
pruneUnreachableMethods
"Remove any methods that are not reachable. Retain methods needed by the translated classes - see implementors of requiredMethodNames"
+ | neededSelectors newMethods previousSize visited |
- | newMethods previousSize visited |
"add all the exported methods and all the called methods to the requiredSelectors"
"keep all the fake methods (macros and struct accessors; these are needed
to ensure correct code generation."
+ neededSelectors := Set withAll: requiredSelectors.
methods do: [ :m |
m export ifTrue:
+ [neededSelectors add: m selector].
- [requiredSelectors add: m selector].
m isRealMethod ifFalse:
+ [neededSelectors add: m selector]].
- [requiredSelectors add: m selector]].
"Now compute the transitive closure..."
+ previousSize := neededSelectors size.
- previousSize := requiredSelectors size.
visited := IdentitySet new: methods size.
+ [neededSelectors do:
- [requiredSelectors do:
[:s|
(methods at: s ifAbsent: []) ifNotNil:
[:m|
(visited includes: m) ifFalse:
[visited add: m.
+ (m isRealMethod
+ and: [self shouldGenerateMethod: m]) ifTrue:
+ [neededSelectors addAll: m allCalls]]]].
+ neededSelectors size > previousSize]
- m isRealMethod ifTrue:
- [requiredSelectors addAll: m allCalls]]]].
- requiredSelectors size > previousSize]
whileTrue:
+ [previousSize := neededSelectors size].
- [previousSize := requiredSelectors size].
"build a new dictionary of methods from the collection of all the ones to keep"
+ newMethods := Dictionary new: neededSelectors size.
+ neededSelectors do:
- newMethods := Dictionary new: requiredSelectors size.
- requiredSelectors do:
[:sel|
+ methods at: sel ifPresent: [:meth| newMethods at: sel put: meth]].
- methods at: sel ifPresent:[:meth| newMethods at: sel put: meth]].
methods := newMethods!
Item was removed:
- ----- Method: CCodeGenerator>>removeUnneededBuiltins (in category 'public') -----
- removeUnneededBuiltins
- | toRemove |
- toRemove := Set new: 64.
- methods keysDo:
- [:sel|
- (self isBuiltinSelector: sel) ifTrue:
- [(requiredSelectors includes: sel) ifFalse:
- [toRemove add: sel]]].
- toRemove do:
- [:sel| self removeMethodForSelector: sel]!
Item was added:
+ ----- Method: CCodeGenerator>>shouldGenerateMethod: (in category 'utilities') -----
+ shouldGenerateMethod: aTMethod
+ ^(self isBuiltinSelector: aTMethod selector)
+ ifTrue: [requiredSelectors includes: aTMethod selector]
+ ifFalse: [true]!
Item was added:
+ ----- Method: CCodeGenerator>>stepExpressionIsNegative: (in category 'C translation') -----
+ stepExpressionIsNegative: aNode
+ "Answer if the step expression (the by: argument in a to:by:do:) is negative."
+ self isConstantNode: aNode valueInto: [:stepValue| ^stepValue < 0].
+ (aNode isSend and: [aNode selector == #negated]) ifTrue:
+ [self isConstantNode: aNode receiver valueInto: [:stepValue| ^stepValue > 0]].
+ ^false!
Item was changed:
----- Method: CoInterpreter>>activateNewClosureMethod:numArgs:mayContextSwitch: (in category 'control primitives') -----
activateNewClosureMethod: blockClosure numArgs: numArgs mayContextSwitch: mayContextSwitch
"Similar to activateNewMethod but for Closure and newMethod.
Override to handle the various interpreter/machine code transitions
and to create an appropriate frame layout."
| numCopied outerContext theMethod methodHeader inInterpreter closureIP switched |
<inline: true>
outerContext := objectMemory fetchPointer: ClosureOuterContextIndex ofObject: blockClosure.
self assert: outerContext ~= blockClosure.
numCopied := self copiedValueCountOfClosure: blockClosure.
theMethod := objectMemory fetchPointer: MethodIndex ofObject: outerContext.
methodHeader := self rawHeaderOf: theMethod.
(self isCogMethodReference: methodHeader) ifTrue:
[^self executeCogBlock: (self cogMethodOf: theMethod)
closure: blockClosure
mayContextSwitch: mayContextSwitch].
"How do we know when to compile a block method?
One simple criterion is to check if the block is running within its inner context,
i.e. if the outerContext is married.
Even simpler is to remember the previous block entered via the interpreter and
compile if this is the same one. But we can thrash trying to compile an uncoggable
method unless we try and remember which ones can't be cogged. So also record
the last block method we failed to compile and avoid recompiling it."
(self methodWithHeaderShouldBeCogged: methodHeader)
ifTrue:
[theMethod = lastCoggableInterpretedBlockMethod
ifTrue:
[theMethod ~= lastUncoggableInterpretedBlockMethod ifTrue:
[cogit cog: theMethod selector: objectMemory nilObject.
(self methodHasCogMethod: theMethod) ifTrue:
[^self executeCogBlock: (self cogMethodOf: theMethod)
closure: blockClosure
mayContextSwitch: mayContextSwitch].
cogCompiledCodeCompactionCalledFor ifFalse:
[lastUncoggableInterpretedBlockMethod := theMethod]]]
ifFalse:
[lastCoggableInterpretedBlockMethod := theMethod]]
ifFalse:
[self maybeFlagMethodAsInterpreted: theMethod].
self assert: (self methodHasCogMethod: theMethod) not.
"Because this is an uncogged method we need to continue via the interpreter.
We could have been reached either from the interpreter, in which case we
should simply return, or from a machine code frame or from a compiled
primitive. In these latter two cases we must longjmp back to the interpreter.
The instructionPointer tells us which path we took.
If the sender was an interpreter frame but called through a (failing) primitive
then make sure we restore the saved instruction pointer and avoid pushing
ceReturnToInterpreterPC which is only valid between an interpreter caller
frame and a machine code callee frame."
(inInterpreter := instructionPointer >= objectMemory startOfMemory) ifFalse:
[instructionPointer = cogit ceReturnToInterpreterPC ifTrue:
[instructionPointer := self iframeSavedIP: framePointer]].
self push: instructionPointer.
self push: framePointer.
framePointer := stackPointer.
self push: theMethod.
self push: objectMemory nilObject. "FxThisContext field"
self push: (self encodeFrameFieldHasContext: false isBlock: true numArgs: numArgs).
self push: 0. "FoxIFSavedIP"
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
-1 for 0-based addressing of fetchByte
-1 because it gets incremented BEFORE fetching currentByte"
closureIP := self quickFetchInteger: ClosureStartPCIndex ofObject: blockClosure.
+ instructionPointer := theMethod + closureIP + objectMemory baseHeaderSize - 2.
- instructionPointer := theMethod + closureIP + BaseHeaderSize - 2.
self setMethod: theMethod methodHeader: methodHeader.
"Now check for stack overflow or an event (interrupt, must scavenge, etc)"
switched := false.
stackPointer < stackLimit ifTrue:
[switched := self handleStackOverflowOrEventAllowContextSwitch: mayContextSwitch].
self returnToExecutive: inInterpreter postContextSwitch: switched!
Item was changed:
----- Method: CoInterpreter>>assertValidExecutionPointe:r:s:imbar:line: (in category 'debug support') -----
assertValidExecutionPointe: lip r: lifp s: lisp imbar: inInterpreter line: ln
<var: #lip type: #usqInt>
<var: #lifp type: #'char *'>
<var: #lisp type: #'char *'>
| methodField cogMethod theIP |
<var: #cogMethod type: #'CogMethod *'>
self assert: stackPage = (stackPages stackPageFor: lifp) l: ln.
self assert: stackPage = stackPages mostRecentlyUsedPage l: ln.
self assert: (self deferStackLimitSmashAround: #assertValidStackLimits: asSymbol with: ln).
self assert: lifp < stackPage baseAddress l: ln.
self assert: lisp < lifp l: ln.
self assert: lifp > lisp l: ln.
self assert: lisp >= (stackPage realStackLimit - self stackLimitOffset) l: ln.
+ self assert: (lifp - lisp) / objectMemory bytesPerOop < LargeContextSlots l: ln.
- self assert: (lifp - lisp) < LargeContextSize l: ln.
methodField := self frameMethodField: lifp.
inInterpreter
ifTrue:
[self assert: (self isMachineCodeFrame: lifp) not l: ln.
self assert: method = methodField l: ln.
self cppIf: MULTIPLEBYTECODESETS
ifTrue: [self assert: (self methodUsesAlternateBytecodeSet: method) = (bytecodeSetSelector = 256) l: ln].
(self asserta: (objectMemory cheapAddressCouldBeInHeap: methodField) l: ln) ifTrue:
[theIP := lip = cogit ceReturnToInterpreterPC
ifTrue: [self iframeSavedIP: lifp]
ifFalse: [lip].
self assert: (theIP >= (methodField + (objectMemory lastPointerOf: methodField))
and: [theIP < (methodField + (objectMemory numBytesOf: methodField) + objectMemory baseHeaderSize - 1)])
l: ln].
self assert: ((self iframeIsBlockActivation: lifp)
or: [(self pushedReceiverOrClosureOfFrame: lifp) = (self iframeReceiver: lifp)])
l: ln]
ifFalse:
[self assert: (self isMachineCodeFrame: lifp) l: ln.
((self asserta: methodField asUnsignedInteger >= cogit minCogMethodAddress l: ln)
and: [self asserta: methodField asUnsignedInteger < cogit maxCogMethodAddress l: ln]) ifTrue:
[cogMethod := self mframeHomeMethod: lifp.
self assert: (lip > (methodField + ((self mframeIsBlockActivation: lifp)
ifTrue: [self sizeof: CogBlockMethod]
ifFalse: [self sizeof: CogMethod]))
and: [lip < (methodField + cogMethod blockSize)])
l: ln].
self assert: ((self mframeIsBlockActivation: lifp)
or: [(self pushedReceiverOrClosureOfFrame: lifp) = (self mframeReceiver: lifp)])
l: ln].
(self isBaseFrame: lifp) ifTrue:
[self assert: (self frameHasContext: lifp) l: ln.
+ self assert: (self frameContext: lifp) = (stackPages longAt: stackPage baseAddress - objectMemory wordSize) l: ln]!
- self assert: (self frameContext: lifp) = (stackPages longAt: stackPage baseAddress - BytesPerWord) l: ln]!
Item was changed:
----- Method: CoInterpreter>>baseFrameReturn (in category 'return bytecodes') -----
baseFrameReturn
"Return from a baseFrame (the bottom frame in a stackPage). The context to
return to (which may be married) is stored in the first word of the stack."
<inline: true>
| contextToReturnTo retToContext theFP theSP thePage newPage frameAbove |
<var: #theFP type: #'char *'>
<var: #theSP type: #'char *'>
<var: #thePage type: #'StackPage *'>
<var: #newPage type: #'StackPage *'>
<var: #frameAbove type: #'char *'>
contextToReturnTo := self frameCallerContext: localFP.
"The stack page is effectively free now, so free it. We must free it to be
correct in determining if contextToReturnTo is still married, and in case
makeBaseFrameFor: cogs a method, which may cause a code compaction,
in which case the frame must be free to avoid the relocation machinery
tracing the dead frame. Since freeing now temporarily violates the page-list
ordering invariant, use the assert-free version."
stackPages freeStackPageNoAssert: stackPage.
retToContext := objectMemory isContext: contextToReturnTo.
(retToContext
and: [self isStillMarriedContext: contextToReturnTo])
ifTrue:
[theFP := self frameOfMarriedContext: contextToReturnTo.
thePage := stackPages stackPageFor: theFP.
theFP = thePage headFP
ifTrue:
[theSP := thePage headSP]
ifFalse:
["Returning to some interior frame, presumably because of a sender assignment.
Move the frames above to another page (they may be in use, e.g. via coroutining).
Make the interior frame the top frame."
frameAbove := self findFrameAbove: theFP inPage: thePage.
"Since we've just deallocated a page we know that newStackPage won't deallocate an existing one."
newPage := self newStackPage.
self assert: newPage = stackPage.
self moveFramesIn: thePage through: frameAbove toPage: newPage.
stackPages markStackPageMostRecentlyUsed: newPage.
theFP := thePage headFP.
theSP := thePage headSP]]
ifFalse:
[(retToContext
and: [objectMemory isIntegerObject: (objectMemory fetchPointer: InstructionPointerIndex ofObject: contextToReturnTo)]) ifFalse:
[| contextToReturnFrom |
+ contextToReturnFrom := stackPages longAt: stackPage baseAddress - objectMemory wordSize.
- contextToReturnFrom := stackPages longAt: stackPage baseAddress - BytesPerWord.
self tearDownAndRebuildFrameForCannotReturnBaseFrameReturnFrom: contextToReturnFrom
to: contextToReturnTo
returnValue: localReturnValue.
^self externalCannotReturn: localReturnValue from: contextToReturnFrom].
"We must void the instructionPointer to stop it being updated if makeBaseFrameFor:
cogs a method, which may cause a code compaction."
instructionPointer := 0.
thePage := self makeBaseFrameFor: contextToReturnTo.
theFP := thePage headFP.
theSP := thePage headSP].
self setStackPageAndLimit: thePage.
self assert: (stackPages stackPageFor: theFP) = stackPage.
localSP := theSP.
localFP := theFP.
localIP := self pointerForOop: self internalStackTop.
localIP asUnsignedInteger < objectMemory startOfMemory ifTrue:
[localIP asUnsignedInteger ~= cogit ceReturnToInterpreterPC ifTrue:
["localIP in the cog method zone indicates a return to machine code."
^self returnToMachineCodeFrame].
localIP := self pointerForOop: (self iframeSavedIP: localFP)].
self assert: (self checkIsStillMarriedContext: contextToReturnTo currentFP: localFP).
self setMethod: (self iframeMethod: localFP).
self internalStackTopPut: localReturnValue.
^self fetchNextBytecode!
Item was changed:
----- Method: CoInterpreter>>ceActiveContext (in category 'trampolines') -----
ceActiveContext
<api>
"Since the trampoline checks for marriage we should only be here for a single frame."
self assert: (self isMachineCodeFrame: framePointer).
self assert: (self frameHasContext: framePointer) not.
"Do *not* include the return pc in the stack contents; hence + BytesPerWord"
+ ^self marryFrame: framePointer SP: stackPointer + objectMemory wordSize!
- ^self marryFrame: framePointer SP: stackPointer + BytesPerWord!
Item was changed:
----- Method: CoInterpreter>>ceBaseFrameReturn: (in category 'trampolines') -----
ceBaseFrameReturn: returnValue
"Return across a page boundary. The context to return to (which may be married)
is stored in the first word of the stack. We get here when a return instruction jumps
to the ceBaseFrameReturn: address that is the return pc for base frames. A consequence
of this is that the current frame is no longer valid since an interrupt may have overwritten
its state as soon as the stack pointer has been cut-back beyond the return pc. So to have
a context to send the cannotReturn: message to we also store the base frame's context
in the second word of the stack page."
<api>
| contextToReturnTo contextToReturnFrom isAContext thePage newPage frameAbove |
<var: #thePage type: #'StackPage *'>
<var: #newPage type: #'StackPage *'>
<var: #frameAbove type: #'char *'>
self assert: (stackPages stackPageFor: stackPointer) = stackPage.
self assert: stackPages mostRecentlyUsedPage = stackPage.
cogit assertCStackWellAligned.
self assert: framePointer = 0.
+ self assert: stackPointer <= (stackPage baseAddress - objectMemory wordSize).
+ self assert: stackPage baseFP + (2 * objectMemory wordSize) < stackPage baseAddress.
- self assert: stackPointer <= (stackPage baseAddress - BytesPerWord).
- self assert: stackPage baseFP + (2 * BytesPerWord) < stackPage baseAddress.
"We would like to use the following assert but we can't since the stack pointer will be above the
base frame pointer in the base frame return and hence the 0 a base frame pointer points at could
be overwritten which will cause the isBaseFrame assert in frameCallerContext: to fail."
"self assert: (self frameCallerContext: stackPage baseFP) = (stackPages longAt: stackPage baseAddress)."
+ self assert: ((objectMemory addressCouldBeObj: (stackPages longAt: stackPage baseAddress - objectMemory wordSize))
+ and: [objectMemory isContext: (stackPages longAt: stackPage baseAddress - objectMemory wordSize)]).
- self assert: ((objectMemory addressCouldBeObj: (stackPages longAt: stackPage baseAddress - BytesPerWord))
- and: [objectMemory isContext: (stackPages longAt: stackPage baseAddress - BytesPerWord)]).
self assert: ((objectMemory addressCouldBeObj: (stackPages longAt: stackPage baseAddress))
and: [objectMemory isContext: (stackPages longAt: stackPage baseAddress)]).
contextToReturnTo := stackPages longAt: stackPage baseAddress.
"The stack page is effectively free now, so free it. We must free it to be
correct in determining if contextToReturnTo is still married, and in case
makeBaseFrameFor: cogs a method, which may cause a code compaction,
in which case the frame must be free to avoid the relocation machinery
tracing the dead frame. Since freeing now temporarily violates the page-list
ordering invariant, use the assert-free version."
stackPages freeStackPageNoAssert: stackPage.
isAContext := objectMemory isContext: contextToReturnTo.
(isAContext
and: [self isStillMarriedContext: contextToReturnTo])
ifTrue:
[framePointer := self frameOfMarriedContext: contextToReturnTo.
thePage := stackPages stackPageFor: framePointer.
framePointer = thePage headFP
ifTrue:
[stackPointer := thePage headSP]
ifFalse:
["Returning to some interior frame, presumably because of a sender assignment.
Move the frames above to another page (they may be in use, e.g. via coroutining).
Make the interior frame the top frame."
frameAbove := self findFrameAbove: framePointer inPage: thePage.
"Since we've just deallocated a page we know that newStackPage won't deallocate an existing one."
newPage := self newStackPage.
self assert: newPage = stackPage.
self moveFramesIn: thePage through: frameAbove toPage: newPage.
stackPages markStackPageMostRecentlyUsed: newPage.
framePointer := thePage headFP.
stackPointer := thePage headSP]]
ifFalse:
[(isAContext
and: [objectMemory isIntegerObject: (objectMemory fetchPointer: InstructionPointerIndex ofObject: contextToReturnTo)]) ifFalse:
+ [contextToReturnFrom := stackPages longAt: stackPage baseAddress - objectMemory wordSize.
- [contextToReturnFrom := stackPages longAt: stackPage baseAddress - BytesPerWord.
self tearDownAndRebuildFrameForCannotReturnBaseFrameReturnFrom: contextToReturnFrom
to: contextToReturnTo
returnValue: returnValue.
^self externalCannotReturn: returnValue from: contextToReturnFrom].
"void the instructionPointer to stop it being incorrectly updated in a code
compaction in makeBaseFrameFor:."
instructionPointer := 0.
thePage := self makeBaseFrameFor: contextToReturnTo.
framePointer := thePage headFP.
stackPointer := thePage headSP].
self setStackPageAndLimit: thePage.
self assert: (stackPages stackPageFor: framePointer) = stackPage.
(self isMachineCodeFrame: framePointer) ifTrue:
[self push: returnValue.
cogit ceEnterCogCodePopReceiverReg.
"NOTREACHED"].
instructionPointer := self stackTop.
instructionPointer = cogit ceReturnToInterpreterPC ifTrue:
[instructionPointer := self iframeSavedIP: framePointer].
self setMethod: (self iframeMethod: framePointer).
self stackTopPut: returnValue. "a.k.a. pop saved ip then push result"
self assert: (self checkIsStillMarriedContext: contextToReturnTo currentFP: framePointer).
self siglong: reenterInterpreter jmp: ReturnToInterpreter.
"NOTREACHED"
^nil!
Item was changed:
----- Method: CoInterpreter>>ceTraceLinkedSend: (in category 'debug support') -----
ceTraceLinkedSend: theReceiver
| cogMethod |
<api>
<var: #cogMethod type: #'CogMethod *'>
cogMethod := self cCoerceSimple: (self stackTop - cogit traceLinkedSendOffset)
to: #'CogMethod *'.
self cCode: [] inSmalltalk:
[cogit checkStackDepthOnSend ifTrue:
[self maybeCheckStackDepth: (cogMethod cmNumArgs > cogit numRegArgs
ifTrue: [cogMethod cmNumArgs + 1]
ifFalse: [0])
+ sp: stackPointer + objectMemory wordSize
- sp: stackPointer + BytesPerWord
pc: (self stackValue: 1)]].
"cogit recordSendTrace ifTrue: is implicit; wouldn't compile the call otherwise."
self recordTrace: (objectMemory fetchClassOf: theReceiver)
thing: cogMethod selector
source: TraceIsFromMachineCode.
cogit printOnTrace ifTrue:
[self printActivationNameFor: cogMethod methodObject
receiver: theReceiver
isBlock: false
firstTemporary: nil;
cr].
self sendBreakpoint: cogMethod selector receiver: theReceiver!
Item was changed:
----- Method: CoInterpreter>>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 *'>
<var: #frameRcvrOffset type: #'char *'>
<var: #cogMethod type: #'CogMethod *'>
ok := true.
0 to: numStackPages - 1 do:
[:i| | thePage theSP theFP frameRcvrOffset 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 + objectMemory wordSize].
- [theSP := theSP + BytesPerWord].
[frameRcvrOffset := self frameReceiverOffset: theFP.
[theSP <= frameRcvrOffset] whileTrue:
[oop := stackPages longAt: theSP.
((objectMemory isNonImmediate: oop)
and: [(objectMemory heapMapAtWord: (self pointerForOop: oop)) = 0]) ifTrue:
[self printFrameThing: 'object leak in frame temp' andFrame: theFP at: theSP.
ok := false].
+ theSP := theSP + objectMemory wordSize].
- theSP := theSP + BytesPerWord].
(self frameHasContext: theFP) ifTrue:
[oop := self frameContext: theFP.
((objectMemory isImmediate: oop)
or: [(objectMemory heapMapAtWord: (self pointerForOop: oop)) = 0]) ifTrue:
[self printFrameThing: 'object leak in frame ctxt' andFrame: theFP at: theFP + FoxThisContext.
ok := false].
(objectMemory isContext: oop) ifFalse:
[self printFrameThing: 'frame ctxt should be context' andFrame: theFP at: theFP + FoxThisContext.
ok := false].
((objectMemory isContext: oop) and: [self isMarriedOrWidowedContext: oop]) ifFalse:
[self printFrameThing: 'frame ctxt should be married' andFrame: theFP at: theFP + FoxThisContext.
ok := false].
((objectMemory isContext: oop) and: [(self frameOfMarriedContext: oop) = theFP]) ifFalse:
[self printFrameThing: 'frame ctxt should be married to this frame ' andFrame: theFP at: theFP + FoxThisContext.
ok := false]].
(self isMachineCodeFrame: theFP)
ifTrue:
[| cogMethod |
cogMethod := self mframeHomeMethod: theFP.
(objectMemory heapMapAtWord: (self pointerForOop: cogMethod)) = 0 ifTrue:
[self printFrameThing: 'object leak in mframe mthd' andFrame: theFP at: theFP + FoxMethod.
ok := false]]
ifFalse:
[oop := self iframeMethod: theFP.
((objectMemory isImmediate: oop)
or: [(objectMemory heapMapAtWord: (self pointerForOop: oop)) = 0]) ifTrue:
[self printFrameThing: 'object leak in iframe mthd' andFrame: theFP at: theFP + FoxMethod.
ok := false]].
(callerFP := self frameCallerFP: theFP) ~= 0] whileTrue:
+ [theSP := theFP + FoxCallerSavedIP + objectMemory wordSize.
- [theSP := theFP + FoxCallerSavedIP + BytesPerWord.
theFP := callerFP].
+ theSP := theFP + FoxCallerSavedIP + objectMemory wordSize.
- theSP := theFP + FoxCallerSavedIP + BytesPerWord.
[theSP <= thePage baseAddress] whileTrue:
[oop := stackPages longAt: theSP.
((objectMemory isNonImmediate: oop)
and: [(objectMemory heapMapAtWord: (self pointerForOop: oop)) = 0]) ifTrue:
[self printFrameThing: 'object leak in frame arg' andFrame: theFP at: theSP.
ok := false].
+ theSP := theSP + objectMemory wordSize]]].
- theSP := theSP + BytesPerWord]]].
^ok!
Item was changed:
----- Method: CoInterpreter>>commonReturn (in category 'return bytecodes') -----
commonReturn
"Do an ^-return (return form method), perhaps checking for unwinds if this is a block activation.
Note: Assumed to be inlined into the dispatch loop."
<sharedCodeNamed: 'commonReturn' inCase: #returnReceiver>
| 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 *'>
"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.
((objectMemory 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: (objectMemory isContext: currentCtx).
stackPages freeStackPage: stackPage.
[(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.
stackPages 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:
[localIP := self pointerForOop: self internalStackTop]
ifFalse:
[[callerFP := localFP.
localFP := self frameCallerFP: localFP.
localFP ~~ frameToReturnTo] whileTrue.
localIP := self frameCallerSavedIP: callerFP.
+ localSP := (self frameCallerSP: callerFP) - objectMemory wordSize].
- localSP := (self frameCallerSP: callerFP) - BytesPerWord].
localIP asUnsignedInteger < objectMemory startOfMemory ifTrue:
[localIP asUnsignedInteger ~= cogit ceReturnToInterpreterPC ifTrue:
["localIP in the cog method zone indicates a return to machine code."
^self returnToMachineCodeFrame].
localIP := self pointerForOop: (self iframeSavedIP: localFP)].
"pop the saved IP, push the return value and continue."
self internalStackTopPut: localReturnValue.
self setMethod: (self iframeMethod: localFP).
^self fetchNextBytecode!
Item was changed:
----- Method: CoInterpreter>>compilationBreak:point: (in category 'debug support') -----
compilationBreak: selectorOop point: selectorLength
<api>
<cmacro: '(sel, len) do { \
if ((len) == breakSelectorLength \
&& !!strncmp((char *)((sel) + BaseHeaderSize), breakSelector, breakSelectorLength)) { \
suppressHeartbeatFlag = 1; \
compilationBreakpointFor(sel); \
} \
} while (0)'>
| i |
breakSelectorLength = selectorLength ifTrue:
[i := breakSelectorLength.
[i > 0] whileTrue:
+ [(objectMemory byteAt: selectorOop + i + objectMemory baseHeaderSize - 1) = (breakSelector at: i) asInteger
- [(objectMemory byteAt: selectorOop + i + BaseHeaderSize - 1) = (breakSelector at: i) asInteger
ifTrue: [(i := i - 1) = 0 ifTrue:
[self compilationBreakpointFor: selectorOop]]
ifFalse: [i := 0]]]!
Item was changed:
----- Method: CoInterpreter>>contextInstructionPointer:frame: (in category 'frame access') -----
contextInstructionPointer: theIP frame: theFP
"Answer a value to store in the InstructionPointer index of a context object for theIP and theFP.
Mapping native pcs to bytecode pcs is quite expensive, requiring a search through the method
map. We mitigate this cost by deferring mapping until we really have to, which is when a context's
instruction pointer is accessed by Smalltalk code (either direct inst var access or through the
instVarAt: primitive). But to defer mapping we have to be able to distinguish machine code from
bytecode pcs, which we do by using negative values for machine code pcs. So if the frame is a
machine code one answer the negation of the offset in the cog method.
As a whorish performance hack we also include the block method offset in the pc of a block.
The least significant 16 bits are the native pc and the most significant 14 bits are the block
start, in block alignment units. So when mapping back we can find the start of the block.
See mustMapMachineCodePC:context: for the code that does the actual mapping."
<var: #theFP type: #'char *'>
<inline: false>
self assert: (self validInstructionPointer: theIP inFrame: theFP).
(self isMachineCodeFrame: theFP) ifTrue:
[^self encodedNativePCOf: theIP cogMethod: (self mframeCogMethod: theFP)].
^objectMemory integerObjectOf: (theIP = cogit ceReturnToInterpreterPC
ifTrue: [self iframeSavedIP: theFP]
ifFalse: [theIP])
- (self iframeMethod: theFP)
+ - objectMemory baseHeaderSize
- - BaseHeaderSize
+ 2!
Item was changed:
----- Method: CoInterpreter>>convertToMachineCodeFrame:bcpc: (in category 'frame access') -----
convertToMachineCodeFrame: cogHomeMethod bcpc: bcpc
<var: #cogHomeMethod type: #'CogHomeMethod *'>
<returnTypeC: #usqInt>
"Convert the current interpreter frame into a machine code frame
and answer the machine code pc matching bcpc."
| startBcpc methodField closure cogMethod pc |
<var: #cogMethod type: #'CogBlockMethod *'>
<var: #p type: #'char *'>
self assert: (self isMachineCodeFrame: framePointer) not.
"Update the return pc, perhaps saving it in the caller's iframeSavedIP."
(self isBaseFrame: framePointer)
ifTrue:
[stackPages
longAt: framePointer + FoxCallerSavedIP
put: cogit ceBaseFrameReturnPC]
ifFalse:
[(self isMachineCodeFrame: (self frameCallerFP: framePointer)) ifFalse:
[self iframeSavedIP: (self frameCallerFP: framePointer)
put: (self frameCallerSavedIP: framePointer) asInteger.
stackPages
longAt: framePointer + FoxCallerSavedIP
put: cogit ceReturnToInterpreterPC]].
"Compute the cog method field"
(self iframeIsBlockActivation: framePointer)
ifTrue:
[closure := self pushedReceiverOrClosureOfFrame: framePointer.
startBcpc := self startPCOfClosure: closure.
cogMethod := cogit
findMethodForStartBcpc: startBcpc
inHomeMethod: cogHomeMethod.
methodField := cogMethod asInteger + MFMethodFlagIsBlockFlag]
ifFalse:
[startBcpc := self startPCOfMethodHeader: cogHomeMethod methodHeader.
cogMethod := self cCoerceSimple: cogHomeMethod to: #'CogBlockMethod *'.
methodField := cogHomeMethod asInteger].
"compute the pc before converting the frame to help with debugging."
pc := cogit mcPCForBackwardBranch: bcpc startBcpc: startBcpc in: cogMethod.
self assert: pc > (cogMethod asUnsignedInteger + cogit noCheckEntryOffset).
self assert: bcpc = (cogit bytecodePCFor: pc startBcpc: startBcpc in: cogMethod).
"now convert to a machine code frame"
stackPages
longAt: framePointer + FoxMethod
put: methodField
+ ((self iframeHasContext: framePointer)
ifTrue: [MFMethodFlagHasContextFlag]
ifFalse: [0]).
+ framePointer + FoxIFReceiver to: stackPointer by: objectMemory wordSize negated do:
- framePointer + FoxIFReceiver to: stackPointer by: BytesPerWord negated do:
[:p|
stackPages longAt: p + FoxMFReceiver - FoxIFReceiver put: (stackPages longAt: p)].
stackPointer := stackPointer + FoxMFReceiver - FoxIFReceiver.
^pc!
Item was changed:
----- Method: CoInterpreter>>createClosureNumArgs:numCopied:startpc: (in category 'trampolines') -----
createClosureNumArgs: numArgs numCopied: numCopied startpc: initialIP
<api>
| context newClosure |
self assert: (self isMachineCodeFrame: framePointer).
"Do *not* include the return pc or copied values in the stack contents;
hence + ((1 + numCopied) * BytesPerWord)"
context := self ensureFrameIsMarried: framePointer
+ SP: stackPointer + ((1 + numCopied) * objectMemory wordSize).
- SP: stackPointer + ((1 + numCopied) * BytesPerWord).
newClosure := self
closureIn: context
numArgs: numArgs
instructionPointer: initialIP
numCopiedValues: numCopied.
cogit recordSendTrace ifTrue:
[self recordTrace: TraceBlockCreation thing: newClosure source: TraceIsFromMachineCode].
numCopied > 0 ifTrue:
["N.B. the expression ((numCopied - i) * BytesPerWord)) skips the return address"
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: (stackPages longAt: stackPointer + ((numCopied - i) * objectMemory wordSize))]].
- withValue: (stackPages longAt: stackPointer + ((numCopied - i) * BytesPerWord))]].
"Assume caller will pop stack"
^newClosure!
Item was changed:
----- Method: CoInterpreter>>divorceAMachineCodeFrameWithCogMethod:in: (in category 'frame access') -----
divorceAMachineCodeFrameWithCogMethod: cogMethod in: aStackPage
"Divorce at most one frame in the current page (since the divorce may cause the page to be split)
and answer whether a frame was divorced."
<var: #cogMethod type: #'CogMethod *'>
<var: #aStackPage type: #'StackPage *'>
| theFP calleeFP theSP theContext |
<var: #aStackPage type: #'StackPage *'>
<var: #theFP type: #'char *'>
<var: #calleeFP type: #'char *'>
<var: #theSP type: #'char *'>
theFP := aStackPage headFP.
theSP := aStackPage headSP.
+ theSP := theSP + objectMemory wordSize. "theSP points at hottest item on frame's stack"
- theSP := theSP + BytesPerWord. "theSP points at hottest item on frame's stack"
[((self isMachineCodeFrame: theFP)
and: [cogMethod = (self mframeHomeMethod: theFP)]) ifTrue:
[theContext := self ensureFrameIsMarried: theFP SP: theSP.
self externalDivorceFrame: theFP andContext: theContext.
^true].
calleeFP := theFP.
theFP := self frameCallerFP: theFP.
theFP ~= 0] whileTrue:
["theSP points at stacked hottest item on frame's stack"
theSP := self frameCallerSP: calleeFP].
^false!
Item was changed:
----- Method: CoInterpreter>>externalWriteBackHeadStackPointer (in category 'cog jit support') -----
externalWriteBackHeadStackPointer
self assert: (stackPointer < stackPage baseAddress
+ and: [stackPointer > (stackPage realStackLimit - (LargeContextSlots * objectMemory bytesPerOop))]).
- and: [stackPointer > (stackPage realStackLimit - LargeContextSize)]).
stackPage headSP: stackPointer!
Item was changed:
----- Method: CoInterpreter>>followForwardingPointersInStackZone: (in category 'object memory support') -----
followForwardingPointersInStackZone: theBecomeEffectsFlags
"Spur's become: is lazy, turning the becommed object into a forwarding object to the other.
The read-barrier is minimised by arranging that forwarding pointers will fail a method cache
probe, since notionally objects' internals are accessed only via sending messages to them,
the exception is primitives that access the internals of the non-receiver argument(s).
To avoid a read barrier on inst var fetch we scan the receivers in the stack zone and follow
any forwarded ones. This is way cheaper than scanning all of memory as in the old become."
| theIPPtr |
<inline: false>
<var: #thePage type: #'StackPage *'>
<var: #theSP type: #'char *'>
<var: #theFP type: #'char *'>
<var: #callerFP type: #'char *'>
<var: #theIPPtr type: #usqInt>
(theBecomeEffectsFlags anyMask: BecameCompiledMethodFlag) ifTrue:
[(objectMemory isForwarded: method) ifTrue:
[theIPPtr := instructionPointer - method.
method := objectMemory followForwarded: method.
instructionPointer := method + theIPPtr].
(objectMemory isForwarded: newMethod) ifTrue:
[newMethod := objectMemory followForwarded: newMethod]].
self assert: stackPage ~= 0.
0 to: numStackPages - 1 do:
[:i| | thePage theSP theFP callerFP oop offset |
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 asUnsignedInteger.
+ theSP := theSP + objectMemory wordSize].
- theSP := theSP + BytesPerWord].
[self assert: (thePage addressIsInPage: theFP).
self assert: (theIPPtr = 0 or: [thePage addressIsInPage: theIPPtr asVoidPointer]).
offset := self frameStackedReceiverOffset: theFP.
oop := stackPages longAt: theFP + offset.
(objectMemory isOopForwarded: oop) ifTrue:
[stackPages
longAt: theFP + offset
put: (objectMemory followForwarded: oop)].
((self frameHasContext: theFP)
and: [(objectMemory isForwarded: (self frameContext: theFP))]) ifTrue:
[stackPages
longAt: theFP + FoxThisContext
put: (objectMemory followForwarded: (self frameContext: theFP))].
(self isMachineCodeFrame: theFP)
ifTrue:
[oop := stackPages longAt: theFP + FoxMFReceiver.
(objectMemory isOopForwarded: oop) ifTrue:
[stackPages
longAt: theFP + FoxMFReceiver
put: (objectMemory followForwarded: oop)].
oop := (self mframeHomeMethod: theFP) methodObject.
self assert: (objectMemory isForwarded: oop) not]
ifFalse:
[oop := stackPages longAt: theFP + FoxIFReceiver.
(objectMemory isOopForwarded: oop) ifTrue:
[stackPages
longAt: theFP + FoxIFReceiver
put: (objectMemory followForwarded: oop)].
oop := self iframeMethod: theFP.
(objectMemory isForwarded: oop) ifTrue:
[| newOop delta |
newOop := objectMemory followForwarded: oop.
delta := newOop - oop.
(theIPPtr ~= 0
and: [(stackPages longAt: theIPPtr) > oop]) ifTrue:
[stackPages
longAt: theIPPtr
put: (stackPages longAt: theIPPtr) + delta].
stackPages
longAt: theFP + FoxIFSavedIP
put: (stackPages longAt: theFP + FoxIFSavedIP) + delta.
stackPages
longAt: theFP + FoxMethod
put: (oop := newOop)]].
(callerFP := self frameCallerFP: theFP) ~= 0] whileTrue:
[theIPPtr := (theFP + FoxCallerSavedIP) asUnsignedInteger.
theFP := callerFP]]]!
Item was changed:
----- Method: CoInterpreter>>frameCallerContext:put: (in category 'frame access') -----
frameCallerContext: theFP put: aValue
"In the StackInterpreter the saved ip field of a base frame holds the
base frame's caller context. But in the Cog VM the first word on the
stack holds the base frame's caller context, which is immediately
above the stacked receiver."
<var: #theFP type: #'char *'>
self assert: (self isBaseFrame: theFP).
+ self assert: theFP + (self frameStackedReceiverOffset: theFP) + (2 * objectMemory wordSize) = (stackPages stackPageFor: theFP) baseAddress.
+ self assert: (stackPages longAt: theFP + (self frameStackedReceiverOffset: theFP) + objectMemory wordSize) = (self frameContext: theFP).
- self assert: theFP + (self frameStackedReceiverOffset: theFP) + (2 * BytesPerWord) = (stackPages stackPageFor: theFP) baseAddress.
- self assert: (stackPages longAt: theFP + (self frameStackedReceiverOffset: theFP) + BytesPerWord) = (self frameContext: theFP).
^stackPages
+ longAt: theFP + (self frameStackedReceiverOffset: theFP) + (2 * objectMemory wordSize)
- longAt: theFP + (self frameStackedReceiverOffset: theFP) + (2 * BytesPerWord)
put: aValue!
Item was changed:
----- Method: CoInterpreter>>handleForwardedSendFaultForReceiver:stackDelta: (in category 'message sending') -----
handleForwardedSendFaultForReceiver: forwardedReceiver stackDelta: stackDelta
"Handle a send fault that may be due to a send to a forwarded object.
Unforward the receiver on the stack and answer it."
<option: #SpurObjectMemory>
| rcvrStackIndex rcvr |
<inline: false>
"should *not* be a super send, so the receiver should be forwarded."
self assert: (objectMemory isOopForwarded: forwardedReceiver).
rcvrStackIndex := argumentCount + stackDelta.
self assert: (self stackValue: rcvrStackIndex) = forwardedReceiver.
rcvr := objectMemory followForwarded: forwardedReceiver.
self stackValue: rcvrStackIndex put: rcvr.
self followForwardedFrameContents: framePointer
+ stackPointer: stackPointer + (rcvrStackIndex + 1 * objectMemory wordSize). "don't repeat effort"
- stackPointer: stackPointer + (rcvrStackIndex + 1 * BytesPerWord). "don't repeat effort"
(objectMemory isPointers: (self frameReceiver: framePointer)) ifTrue:
[objectMemory
followForwardedObjectFields: (self frameReceiver: framePointer)
toDepth: 0].
self followForwardedFieldsInCurrentMethod.
^rcvr!
Item was changed:
----- Method: CoInterpreter>>ifBackwardsCheckForEvents: (in category 'jump bytecodes') -----
ifBackwardsCheckForEvents: offset
"Backward jump means we're in a loop.
- check for possible interrupts.
- check for long-running loops and JIT if appropriate."
| switched backwardJumpCountByte |
<inline: true>
offset >= 0 ifTrue:
[^self].
localSP < stackLimit ifTrue:
[self externalizeIPandSP.
switched := self checkForEventsMayContextSwitch: true.
self returnToExecutive: true postContextSwitch: switched.
self browserPluginReturnIfNeeded.
self internalizeIPandSP.
switched ifTrue:
[^self]].
"We use the least significant byte of the flags word (which is marked as an immediate) and
subtract two each time to avoid disturbing the least significant tag bit. Since the byte is
initialized to 1 (on frame build), on first decrement it will become -1. Trip when it reaches 1 again."
backwardJumpCountByte := self iframeBackwardBranchByte: localFP.
(backwardJumpCountByte := backwardJumpCountByte - 2) = 1
ifTrue:
[(self methodWithHeaderShouldBeCogged: (objectMemory methodHeaderOf: method)) ifTrue:
[self externalizeIPandSP.
+ self attemptToSwitchToMachineCode: (self oopForPointer: localIP) - offset - method - objectMemory baseHeaderSize - 1
- self attemptToSwitchToMachineCode: (self oopForPointer: localIP) - offset - method - BaseHeaderSize - 1
"If attemptToSwitchToMachineCode: returns the method could not be cogged, hence..."].
"can't cog method; avoid asking to cog it again for the longest possible time."
backwardJumpCountByte := 16r7F]
ifFalse:
[backwardJumpCountByte = -1 ifTrue: "initialize the count"
[self assert: minBackwardJumpCountForCompile <= 128.
backwardJumpCountByte := minBackwardJumpCountForCompile - 1 << 1 + 1]].
self iframeBackwardBranchByte: localFP put: backwardJumpCountByte!
Item was changed:
----- Method: CoInterpreter>>iframeBackwardBranchByte: (in category 'frame access') -----
iframeBackwardBranchByte: theFP
"See encodeFrameFieldHasContext:numArgs: and ifBackwardsCheckForEvents:"
<inline: true>
<var: #theFP type: #'char *'>
+ ^stackPages byteAt: theFP + (VMBIGENDIAN ifTrue: [FoxIFrameFlags + objectMemory wordSize - 1] ifFalse: [FoxIFrameFlags])!
- ^stackPages byteAt: theFP + (VMBIGENDIAN ifTrue: [FoxIFrameFlags + BytesPerWord - 1] ifFalse: [FoxIFrameFlags])!
Item was changed:
----- Method: CoInterpreter>>iframeBackwardBranchByte:put: (in category 'frame access') -----
iframeBackwardBranchByte: theFP put: aByte
"See encodeFrameFieldHasContext:numArgs: and ifBackwardsCheckForEvents:"
<inline: true>
<var: #theFP type: #'char *'>
stackPages
+ byteAt: theFP + (VMBIGENDIAN ifTrue: [FoxIFrameFlags + objectMemory wordSize - 1] ifFalse: [FoxIFrameFlags])
- byteAt: theFP + (VMBIGENDIAN ifTrue: [FoxIFrameFlags + BytesPerWord - 1] ifFalse: [FoxIFrameFlags])
put: aByte!
Item was changed:
----- Method: CoInterpreter>>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."
"Override to establish the setjmp/longjmp handler for reentering the interpreter
from machine code, and disable executablity on the heap and stack pages."
"This should be in its own initStackPages method but Slang can't inline
C code strings."
| stackPageBytes stackPagesBytes theStackMemory |
<var: #theStackMemory type: #'char *'>
stackPageBytes := self stackPageByteSize.
stackPagesBytes := self computeStackZoneSize.
theStackMemory := self
cCode: [self alloca: stackPagesBytes]
inSmalltalk: [stackPages initializeWithByteSize: stackPagesBytes for: self].
self cCode: [self me: theStackMemory ms: 0 et: stackPagesBytes].
self sqMakeMemoryNotExecutableFrom: objectMemory startOfMemory asUnsignedInteger
To: objectMemory memoryLimit asUnsignedInteger.
self sqMakeMemoryNotExecutableFrom: theStackMemory asUnsignedInteger
To: theStackMemory asUnsignedInteger + stackPagesBytes.
stackPages
initializeStack: theStackMemory
+ numSlots: stackPagesBytes / objectMemory wordSize
+ pageSize: stackPageBytes / objectMemory wordSize.
- numSlots: stackPagesBytes / BytesPerWord
- pageSize: stackPageBytes / BytesPerWord.
self assert: self minimumUnusedHeadroom = stackPageBytes.
"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 initialEnterSmalltalkExecutive.
^nil!
Item was added:
+ ----- Method: CoInterpreter>>initializeFrameIndices (in category 'as yet unclassified') -----
+ 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 saved ip/this stackPage (for a base frame)
+ fp-> saved fp
+ method
+ context (initialized to nil)
+ frame flags (interpreter only)
+ saved method ip (initialized to 0; interpreter only)
+ receiver
+ first temp
+ ...
+ sp-> Nth temp
+
+ In an interpreter frame
+ frame flags holds
+ the backward jump count (see ifBackwardsCheckForEvents)
+ 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).
+ saved method ip holds the saved method ip when the callee frame is a machine code frame.
+ This is because the saved method ip is actually the ceReturnToInterpreterTrampoline address.
+ In a machine code frame
+ the flag indicating if the context is valid is the least significant bit of the method pointer
+ the flag for a block activation is the next most significant bit of the method pointer
+
+ Interpreter frames are distinguished from method frames by the method field which will
+ be a pointer into the heap for an interpreter frame and a pointer into the method zone for
+ a machine code frame.
+
+ The first frame in a stack page is the baseFrame and is marked as such by a saved fp being its stackPage,
+ in which case the first word on the stack is the caller context (possibly hybrid) beneath the base frame."
+
+ | fxCallerSavedIP fxSavedFP fxMethod fxIFrameFlags fxThisContext fxIFReceiver fxMFReceiver fxIFSavedIP |
+ fxCallerSavedIP := 1.
+ fxSavedFP := 0.
+ fxMethod := -1.
+ fxThisContext := -2.
+ fxIFrameFlags := -3. "Can find numArgs, needed for fast temp access. args are above fxCallerSavedIP.
+ Can find ``is block'' bit
+ Can find ``has context'' bit"
+ fxIFSavedIP := -4.
+ fxIFReceiver := -5.
+ fxMFReceiver := -3.
+
+ "For debugging nil out values that differ in the StackInterpreter."
+ FrameSlots := #undeclared.
+ IFrameSlots := fxCallerSavedIP - fxIFReceiver + 1.
+ MFrameSlots := fxCallerSavedIP - fxMFReceiver + 1.
+
+ FoxCallerSavedIP := fxCallerSavedIP * objectMemory wordSize.
+ "In Cog a base frame's caller context is stored on the first word of the stack page."
+ FoxCallerContext := #undeclared.
+ FoxSavedFP := fxSavedFP * objectMemory wordSize.
+ FoxMethod := fxMethod * objectMemory wordSize.
+ FoxThisContext := fxThisContext * objectMemory wordSize.
+ FoxFrameFlags := #undeclared.
+ FoxIFrameFlags := fxIFrameFlags * objectMemory wordSize.
+ FoxIFSavedIP := fxIFSavedIP * objectMemory wordSize.
+ FoxReceiver := #undeclared.
+ FoxIFReceiver := fxIFReceiver * objectMemory wordSize.
+ FoxMFReceiver := fxMFReceiver * objectMemory wordSize.
+
+ "N.B. There is room for one more flag given the current 8 byte alignment of methods (which
+ is at least needed to distinguish the checked and uncecked entry points by their alignment."
+ MFMethodFlagHasContextFlag := 1.
+ MFMethodFlagIsBlockFlag := 2.
+ MFMethodFlagFrameIsMarkedFlag := 4. "for pathTo:using:followWeak:"
+ MFMethodFlagsMask := MFMethodFlagHasContextFlag + MFMethodFlagIsBlockFlag + MFMethodFlagFrameIsMarkedFlag.
+ MFMethodMask := (MFMethodFlagsMask + 1) negated!
Item was changed:
----- Method: CoInterpreter>>interpretMethodFromMachineCode (in category 'message sending') -----
interpretMethodFromMachineCode
"Execute a method interpretively from machine code. We assume (require) that newMethod
messageSelector, primitiveFunctionPointer and argumentCount have been set in the caller.
Once evaluated either continue in the interpreter via a jongjmp or in machine code via an
enilopmart (a form of longjmp - a stinking rose by any other name)."
<inline: false>
cogit assertCStackWellAligned.
self assert: (self validInstructionPointer: instructionPointer inFrame: framePointer).
primitiveFunctionPointer ~= 0
ifTrue:
[primitiveFunctionPointer = #primitiveInvokeObjectAsMethod
ifTrue: [self assert: (objectMemory isOopCompiledMethod: newMethod) not]
ifFalse: [self assert: ((objectMemory isOopCompiledMethod: newMethod)
and: [(self primitiveIndexOf: newMethod) ~= 0])].
"Invoke an interpreter primitive (because the method is to be interpreted or has not yet been
compiled). This is very similar to invoking an interpreter primitive from a compiled primitive
(see e.g. SimpleStackBasedCogit>>compileInterpreterPrimitive:). Cut back the stack pointer
(done above) to skip the return address and invoke the function. On return if it has succeeded
simply continue otherwise restore the stackPointer, collect the pc and interpret. Note that
frame building primitives such as primitiveClosureValue, primitiveEvaluateMethod et al will not
return but will instead jump into either machine code or longjmp back to the interpreter."
"Assign stackPage headFP so we can tell if the primitive built a frame. We can't simply save
the framePointer since e.g. assignment to contexts (via primitiveInstVarAt:put:) can change the
framePointer. But context assignments will change both the framePointer and stackPage headFP."
self assert: (framePointer < stackPage baseAddress
+ and: [framePointer > (stackPage realStackLimit - (LargeContextSlots * objectMemory bytesPerOop / 2))]).
- and: [framePointer > (stackPage realStackLimit - (LargeContextSize / 2))]).
stackPage headFP: framePointer.
self isPrimitiveFunctionPointerAnIndex
ifTrue:
[self externalQuickPrimitiveResponse.
primFailCode := 0]
ifFalse:
[self slowPrimitiveResponse].
self successful ifTrue:
[self return: self popStack toExecutive: false
"NOTREACHED"]]
ifFalse:
[self assert: ((objectMemory isOopCompiledMethod: newMethod)
and: [(self primitiveIndexOf: newMethod) = 0
or: [(self functionPointerFor: (self primitiveIndexOf: newMethod) inClass: objectMemory nilObject) = 0
or: [self isNullExternalPrimitiveCall: newMethod]]])].
"if not primitive, or primitive failed, activate the method and reenter the interpreter"
self activateNewMethod.
self siglong: reenterInterpreter jmp: ReturnToInterpreter.
"NOTREACHED"
^nil!
Item was changed:
----- Method: CoInterpreter>>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."
| maxUsedBytesPerPage maxFramesPerPage |
maxUsedBytesPerPage := self stackPageFrameBytes + self stackLimitOffset.
+ maxFramesPerPage := maxUsedBytesPerPage / objectMemory wordSize // MFrameSlots.
+ ^maxFramesPerPage * LargeContextSlots * objectMemory bytesPerOop * numStackPages!
- maxFramesPerPage := maxUsedBytesPerPage / BytesPerWord // MFrameSlots.
- ^maxFramesPerPage * LargeContextSlots * BytesPerOop * numStackPages!
Item was changed:
----- Method: CoInterpreter>>itemporary:in: (in category 'internal interpreter access') -----
itemporary: offset in: theFP
"Temporary access for an interpreter frame only."
"See StackInterpreter class>>initializeFrameIndices"
| frameNumArgs |
<inline: true>
<var: #theFP type: #'char *'>
^offset < (frameNumArgs := self iframeNumArgs: theFP)
+ ifTrue: [stackPages longAt: theFP + FoxCallerSavedIP + ((frameNumArgs - offset) * objectMemory wordSize)]
+ ifFalse: [stackPages longAt: theFP + FoxIFReceiver - objectMemory wordSize + ((frameNumArgs - offset) * objectMemory wordSize)]!
- ifTrue: [stackPages longAt: theFP + FoxCallerSavedIP + ((frameNumArgs - offset) * BytesPerWord)]
- ifFalse: [stackPages longAt: theFP + FoxIFReceiver - BytesPerWord + ((frameNumArgs - offset) * BytesPerWord)]!
Item was changed:
----- Method: CoInterpreter>>itemporary:in:put: (in category 'internal interpreter access') -----
itemporary: offset in: theFP put: valueOop
"Temporary access for an interpreter frame only."
"See StackInterpreter class>>initializeFrameIndices"
| frameNumArgs |
<inline: true>
<var: #theFP type: #'char *'>
^offset < (frameNumArgs := self iframeNumArgs: theFP)
+ ifTrue: [stackPages longAt: theFP + FoxCallerSavedIP + ((frameNumArgs - offset) * objectMemory wordSize) put: valueOop]
+ ifFalse: [stackPages longAt: theFP + FoxIFReceiver - objectMemory wordSize + ((frameNumArgs - offset) * objectMemory wordSize) put: valueOop]!
- ifTrue: [stackPages longAt: theFP + FoxCallerSavedIP + ((frameNumArgs - offset) * BytesPerWord) put: valueOop]
- ifFalse: [stackPages longAt: theFP + FoxIFReceiver - BytesPerWord + ((frameNumArgs - offset) * BytesPerWord) put: valueOop]!
Item was changed:
----- Method: CoInterpreter>>lookupAddress: (in category 'simulation') -----
lookupAddress: address
"If address appears to be that of a Symbol or a few well-known objects (such as classes) answer it, otherwise answer nil.
For code disassembly"
<doNotGenerate>
(objectMemory lookupAddress: address) ifNotNil:
[:lookup| ^lookup].
+ address / objectMemory wordSize = primTraceLog offset ifTrue: [^'primTraceLog'].
- address / BytesPerWord = primTraceLog offset ifTrue: [^'primTraceLog'].
^nil!
Item was changed:
----- Method: CoInterpreter>>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. Override to
hold the caller context in a different place, In the StackInterpreter we use
the caller saved ip, but in the Cog VM caller saved ip is the ceBaseReturn:
trampoline. Simply hold the caller context in the first word of the stack."
<returnTypeC: #'StackPage *'>
| page pointer theMethod theIP numArgs stackPtrIndex maybeClosure rcvr |
<inline: false>
<var: #page type: #'StackPage *'>
<var: #pointer type: #'char *'>
<var: #cogMethod type: #'CogMethod *'>
"theIP must be typed as signed because it is assigned ceCannotResumePC and so maybe implicitly typed as unsigned."
<var: #theIP type: #sqInt>
self assert: (self isSingleContext: aContext).
self assert: (objectMemory goodContextSize: aContext).
theIP := objectMemory fetchPointer: InstructionPointerIndex ofObject: aContext.
self assert: HasBeenReturnedFromMCPC signedIntFromLong < 0.
theIP := (objectMemory isIntegerObject: theIP)
ifTrue: [objectMemory integerValueOf: theIP]
ifFalse: [HasBeenReturnedFromMCPC].
theMethod := objectMemory followObjField: MethodIndex ofObject: aContext.
page := self newStackPage.
"first word on stack is caller context of base frame"
stackPages
longAt: (pointer := page baseAddress)
put: (objectMemory fetchPointer: SenderIndex ofObject: aContext).
"second word is the context itself; needed for cannotReturn processing; see ceBaseReturn:."
stackPages
+ longAt: (pointer := pointer - objectMemory wordSize)
- longAt: (pointer := pointer - BytesPerWord)
put: aContext.
rcvr := objectMemory followField: ReceiverIndex 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 := pointer - objectMemory wordSize)
- longAt: (pointer := pointer - BytesPerWord)
put: maybeClosure]
ifFalse:
[| header |
header := objectMemory methodHeaderOf: theMethod.
numArgs := self argumentCountOfMethodHeader: header.
"If this is a synthetic context its IP could be pointing at the CallPrimitive opcode. If so, skip it."
(theIP signedIntFromLong > 0
and: [(self methodHeaderHasPrimitive: header)
and: [theIP = (1 + (objectMemory lastPointerOf: theMethod))]]) ifTrue:
[theIP := theIP + (self sizeOfCallPrimitiveBytecode: header)].
stackPages
+ longAt: (pointer := pointer - objectMemory wordSize)
- longAt: (pointer := pointer - BytesPerWord)
put: rcvr].
"Put the arguments on the stack"
1 to: numArgs do:
[:i|
stackPages
+ longAt: (pointer := pointer - objectMemory wordSize)
- longAt: (pointer := pointer - BytesPerWord)
put: (objectMemory fetchPointer: ReceiverIndex + i ofObject: aContext)].
"saved caller ip is base return trampoline"
stackPages
+ longAt: (pointer := pointer - objectMemory wordSize)
- longAt: (pointer := pointer - BytesPerWord)
put: cogit ceBaseFrameReturnPC.
"base frame's saved fp is null"
stackPages
+ longAt: (pointer := pointer - objectMemory wordSize)
- longAt: (pointer := pointer - BytesPerWord)
put: 0.
"N.B. Don't set the baseFP, which marks the page as in use, until after
ensureMethodIsCogged: and/or instructionPointer:forContext:frame:. These
can cause a compiled code compaction which, if marked as in use, will
examine this partially initialized page and crash."
page headFP: pointer.
"Create either a machine code frame or an interpreter frame based on the pc. If the pc is -ve
it is a machine code pc and so we produce a machine code frame. If +ve an interpreter frame.
N.B. Do *not* change this to try and map from a bytecode pc to a machine code frame under
any circumstances. See ensureContextIsExecutionSafeAfterAssignToStackPointer:"
theIP signedIntFromLong < 0
ifTrue:
[| cogMethod |
"Since we would have to generate a machine-code method to be able to map
the native pc anyway we should create a native method and native frame."
cogMethod := self ensureMethodIsCogged: theMethod.
theMethod := cogMethod asInteger.
maybeClosure ~= objectMemory nilObject
ifTrue:
["If the pc is the special HasBeenReturnedFromMCPC pc set the pc
appropriately so that the frame stays in the cannotReturn: state."
theIP = HasBeenReturnedFromMCPC signedIntFromLong
ifTrue:
[theMethod := (cogit findMethodForStartBcpc: (self startPCOfClosure: maybeClosure)
inHomeMethod: (self cCoerceSimple: theMethod
to: #'CogMethod *')) asInteger.
theMethod = 0 ifTrue:
[self error: 'cannot find machine code block matching closure''s startpc'].
theIP := cogit ceCannotResumePC]
ifFalse:
[self assert: (theIP signedBitShift: -16) < -1. "See contextInstructionPointer:frame:"
theMethod := theMethod - ((theIP signedBitShift: -16) * cogit blockAlignment).
theIP := theMethod - theIP signedIntFromShort].
stackPages
+ longAt: (pointer := pointer - objectMemory wordSize)
- longAt: (pointer := pointer - BytesPerWord)
put: theMethod + MFMethodFlagHasContextFlag + MFMethodFlagIsBlockFlag]
ifFalse:
[self assert: (theIP signedBitShift: -16) >= -1.
"If the pc is the special HasBeenReturnedFromMCPC pc set the pc
appropriately so that the frame stays in the cannotReturn: state."
theIP := theIP = HasBeenReturnedFromMCPC signedIntFromLong
ifTrue: [cogit ceCannotResumePC]
ifFalse: [theMethod asInteger - theIP].
stackPages
+ longAt: (pointer := pointer - objectMemory wordSize)
- longAt: (pointer := pointer - BytesPerWord)
put: theMethod + MFMethodFlagHasContextFlag].
stackPages
+ longAt: (pointer := pointer - objectMemory wordSize)
- longAt: (pointer := pointer - BytesPerWord)
put: aContext]
ifFalse:
[stackPages
+ longAt: (pointer := pointer - objectMemory wordSize)
- longAt: (pointer := pointer - BytesPerWord)
put: theMethod.
stackPages
+ longAt: (pointer := pointer - objectMemory wordSize)
- longAt: (pointer := pointer - BytesPerWord)
put: aContext.
stackPages
+ longAt: (pointer := pointer - objectMemory wordSize)
- longAt: (pointer := pointer - BytesPerWord)
put: (self encodeFrameFieldHasContext: true isBlock: maybeClosure ~= objectMemory nilObject numArgs: numArgs).
stackPages
+ longAt: (pointer := pointer - objectMemory wordSize)
- longAt: (pointer := pointer - BytesPerWord)
put: 0. "FoxIFSavedIP"
theIP := self iframeInstructionPointerForIndex: theIP method: theMethod].
page baseFP: page headFP.
self assert: (self frameHasContext: page baseFP).
self assert: (self frameNumArgs: page baseFP) == numArgs.
stackPages
+ longAt: (pointer := pointer - objectMemory wordSize)
- longAt: (pointer := pointer - BytesPerWord)
put: rcvr.
stackPtrIndex := self quickFetchInteger: StackPointerIndex ofObject: aContext.
self assert: ReceiverIndex + stackPtrIndex < (objectMemory lengthOf: aContext).
numArgs + 1 to: stackPtrIndex do:
[:i|
stackPages
+ longAt: (pointer := pointer - objectMemory wordSize)
- longAt: (pointer := pointer - BytesPerWord)
put: (objectMemory fetchPointer: ReceiverIndex + i ofObject: aContext)].
"top of stack is the instruction pointer"
+ stackPages longAt: (pointer := pointer - objectMemory wordSize) put: theIP.
- stackPages longAt: (pointer := pointer - BytesPerWord) put: theIP.
page headSP: pointer.
self assert: (self context: aContext hasValidInversePCMappingOf: theIP in: page baseFP).
"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) plus SmallInteger tags."
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.
self assert: (self validStackPageBaseFrame: page).
^page!
Item was changed:
----- Method: CoInterpreter>>mapStackPages (in category 'object memory support') -----
mapStackPages
<inline: false>
<var: #thePage type: #'StackPage *'>
<var: #theSP type: #'char *'>
<var: #theFP type: #'char *'>
<var: #frameRcvrOffset type: #'char *'>
<var: #callerFP type: #'char *'>
<var: #theIPPtr type: #'char *'>
0 to: numStackPages - 1 do:
[:i| | thePage theSP theFP frameRcvrOffset 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 := ((self isMachineCodeFrame: theFP)
or: [(self iframeSavedIP: theFP) = 0])
ifTrue: [0]
ifFalse: [theFP + FoxIFSavedIP]]
ifFalse:
[theIPPtr := theSP.
+ theSP := theSP + objectMemory wordSize].
- theSP := theSP + BytesPerWord].
[self assert: (thePage addressIsInPage: theFP).
self assert: (thePage addressIsInPage: theSP).
self assert: (theIPPtr = 0 or: [thePage addressIsInPage: theIPPtr]).
frameRcvrOffset := self frameReceiverOffset: theFP.
[theSP <= frameRcvrOffset] whileTrue:
[oop := stackPages longAt: theSP.
(objectMemory shouldRemapOop: oop) ifTrue:
[stackPages longAt: theSP put: (objectMemory remapObj: oop)].
+ theSP := theSP + objectMemory wordSize].
- theSP := theSP + BytesPerWord].
(self frameHasContext: theFP) ifTrue:
[(objectMemory shouldRemapObj: (self frameContext: theFP)) ifTrue:
[stackPages
longAt: theFP + FoxThisContext
put: (objectMemory remapObj: (self frameContext: theFP))].
"forwarding scheme in SqueakV3 obj rep makes this hard to check."
objectMemory hasSpurMemoryManagerAPI ifTrue:
[self assert: ((self isMarriedOrWidowedContext: (self frameContext: theFP))
and: [(self frameOfMarriedContext: (self frameContext: theFP)) = theFP])]].
(self isMachineCodeFrame: theFP) ifFalse:
[(objectMemory shouldRemapObj: (self iframeMethod: theFP)) ifTrue:
[theIPPtr ~= 0 ifTrue:
[theIP := stackPages longAt: theIPPtr.
theIP = cogit ceReturnToInterpreterPC
ifTrue:
[self assert: (self iframeSavedIP: theFP) > (self iframeMethod: theFP).
theIPPtr := theFP + FoxIFSavedIP.
theIP := stackPages longAt: theIPPtr]
ifFalse:
[self assert: theIP > (self iframeMethod: theFP)].
theIP := theIP - (self iframeMethod: theFP)].
stackPages
longAt: theFP + FoxMethod
put: (objectMemory remapObj: (self iframeMethod: theFP)).
theIPPtr ~= 0 ifTrue:
[stackPages longAt: theIPPtr put: theIP + (self iframeMethod: theFP)]]].
(callerFP := self frameCallerFP: theFP) ~= 0] whileTrue:
+ [theSP := (theIPPtr := theFP + FoxCallerSavedIP) + objectMemory wordSize.
- [theSP := (theIPPtr := theFP + FoxCallerSavedIP) + BytesPerWord.
theFP := callerFP].
+ theSP := theFP + FoxCallerSavedIP + objectMemory wordSize.
- theSP := theFP + FoxCallerSavedIP + BytesPerWord.
[theSP <= thePage baseAddress] whileTrue:
[oop := stackPages longAt: theSP.
(objectMemory shouldRemapOop: oop) ifTrue:
[stackPages longAt: theSP put: (objectMemory remapObj: oop)].
+ theSP := theSP + objectMemory wordSize]]]!
- theSP := theSP + BytesPerWord]]]!
Item was changed:
----- Method: CoInterpreter>>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.
self assert: thePage trace ~= StackPageTraced.
thePage trace: StackPageTraced.
theSP := thePage headSP.
theFP := thePage headFP.
"Skip the instruction pointer on top of stack of inactive pages."
thePage = stackPage ifFalse:
+ [theSP := theSP + objectMemory wordSize].
- [theSP := theSP + BytesPerWord].
[frameRcvrOffset := self frameReceiverOffset: theFP.
[theSP <= frameRcvrOffset] whileTrue:
[oop := stackPages longAt: theSP.
(objectMemory isOopForwarded: oop) ifTrue:
[oop := objectMemory followForwarded: oop.
stackPages longAt: theSP put: oop].
(objectMemory isImmediate: oop) ifFalse:
[objectMemory markAndTrace: oop].
+ theSP := theSP + objectMemory wordSize].
- theSP := theSP + BytesPerWord].
(self frameHasContext: theFP) ifTrue:
[self assert: (objectMemory isContext: (self frameContext: theFP)).
objectMemory markAndTrace: (self frameContext: theFP)].
(self isMachineCodeFrame: theFP)
ifTrue: [self markAndTraceMachineCodeMethod: (self mframeCogMethod: theFP)]
ifFalse: [objectMemory markAndTrace: (self iframeMethod: theFP)].
(callerFP := self frameCallerFP: theFP) ~= 0] whileTrue:
+ [theSP := theFP + FoxCallerSavedIP + objectMemory wordSize.
- [theSP := theFP + FoxCallerSavedIP + BytesPerWord.
theFP := callerFP].
+ theSP := theFP + FoxCallerSavedIP + objectMemory wordSize. "caller ip is ceBaseReturnPC"
- theSP := theFP + FoxCallerSavedIP + BytesPerWord. "caller ip is ceBaseReturnPC"
[theSP <= thePage baseAddress] whileTrue:
[oop := stackPages longAt: theSP.
(objectMemory isOopForwarded: oop) ifTrue:
[oop := objectMemory followForwarded: oop.
stackPages longAt: theSP put: oop].
(objectMemory isImmediate: oop) ifFalse:
[objectMemory markAndTrace: oop].
+ theSP := theSP + objectMemory wordSize]!
- theSP := theSP + BytesPerWord]!
Item was changed:
----- Method: CoInterpreter>>methodCacheAddress (in category 'cog jit support') -----
methodCacheAddress
<api>
<returnTypeC: #'void *'>
+ ^self cCode: 'GIV(methodCache)' inSmalltalk: [methodCache offset * objectMemory wordSize]!
- ^self cCode: 'GIV(methodCache)' inSmalltalk: [methodCache offset * BytesPerWord]!
Item was changed:
----- Method: CoInterpreter>>minimumUnusedHeadroom (in category 'debug support') -----
minimumUnusedHeadroom
"Traverse all stack pages looking for non-zero bytes in the headroom part of each page.
Answer the minimum size of unused headroom (zero bytes) in the pages. This is for
checking that there is enough headroom allocated in stack pages."
| minUnused page |
<var: #page type: #'StackPage *'>
<var: #p type: #'char *'>
minUnused := (stackPages stackPageAt: 0) baseAddress - (stackPages stackPageAt: 0) lastAddress.
0 to: numStackPages - 1 do:
[:i| | p unused |
page := stackPages stackPageAt: i.
p := page lastAddress.
+ [p := p + objectMemory wordSize.
- [p := p + BytesPerWord.
(self longAtPointer: p) = 0
and: [p <= page baseAddress]] whileTrue.
+ unused := p - objectMemory wordSize - page lastAddress.
- unused := p - BytesPerWord - page lastAddress.
unused < minUnused ifTrue:
[minUnused := unused]].
^minUnused!
Item was changed:
----- Method: CoInterpreter>>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 *'>
"A base frame must have a context for cannotReturn: processing."
self assert: (self isBaseFrame: theFP) not.
self assert: self validStackPageBaseFrames.
callerFP := self frameCallerFP: theFP.
self assert: (self frameHasContext: callerFP).
self assert: (objectMemory isContext: (self frameContext: callerFP)).
theContext := self ensureFrameIsMarried: theFP
SP: theFP + ((self isMachineCodeFrame: theFP) ifTrue: [FoxMFReceiver] ifFalse: [FoxIFReceiver]).
stackPages
longAt: (newSP := newPage baseAddress) put: (self frameContext: callerFP);
+ longAt: (newSP := newSP - objectMemory wordSize) put: theContext.
- longAt: (newSP := newSP - BytesPerWord) put: theContext.
stackedReceiverOffset := self frameStackedReceiverOffset: theFP.
"First move the data, leaving room for the caller and base frame contexts. We will fix up frame pointers later."
theFP + stackedReceiverOffset
to: oldPage headSP
+ by: objectMemory wordSize negated
- by: BytesPerWord negated
do: [:source|
+ newSP := newSP - objectMemory wordSize.
- newSP := newSP - BytesPerWord.
stackPages longAt: newSP put: (stackPages longAt: source)].
"newSP = oldSP + delta => delta = newSP - oldSP"
delta := newSP - oldPage headSP.
+ newFP := newPage baseAddress - stackedReceiverOffset - (2 * objectMemory wordSize).
- newFP := newPage baseAddress - stackedReceiverOffset - (2 * BytesPerWord).
self setHeadFP: oldPage headFP + delta andSP: newSP inPage: newPage.
newPage baseFP: newFP.
callerIP := self oopForPointer: (self frameCallerSavedIP: theFP).
callerIP asUnsignedInteger >= objectMemory startOfMemory ifTrue:
[self iframeSavedIP: callerFP put: callerIP.
callerIP := cogit ceReturnToInterpreterPC].
stackPages longAt: theFP + stackedReceiverOffset put: callerIP.
self assert: (callerFP < oldPage baseAddress
+ and: [callerFP > (oldPage realStackLimit - (LargeContextSlots * objectMemory bytesPerOop / 2))]).
- and: [callerFP > (oldPage realStackLimit - (LargeContextSize / 2))]).
oldPage
headFP: callerFP;
headSP: theFP + stackedReceiverOffset.
"Mark the new base frame in the new page"
stackPages
longAt: newFP + FoxCallerSavedIP put: cogit ceBaseFrameReturnPC;
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.
self assert: self validStackPageBaseFrames.
^newFP!
Item was changed:
----- Method: CoInterpreter>>mtemporary:in:put: (in category 'internal interpreter access') -----
mtemporary: offset in: theFP put: valueOop
"Temporary access for a machine code frame only."
"See StackInterpreter class>>initializeFrameIndices"
| frameNumArgs |
<inline: true>
<var: #theFP type: #'char *'>
^stackPages
longAt: (offset < (frameNumArgs := self mframeNumArgs: theFP)
+ ifTrue: [theFP + FoxCallerSavedIP + ((frameNumArgs - offset) * objectMemory wordSize)]
+ ifFalse: [theFP + FoxMFReceiver - objectMemory wordSize + ((frameNumArgs - offset) * objectMemory wordSize)])
- ifTrue: [theFP + FoxCallerSavedIP + ((frameNumArgs - offset) * BytesPerWord)]
- ifFalse: [theFP + FoxMFReceiver - BytesPerWord + ((frameNumArgs - offset) * BytesPerWord)])
put: valueOop!
Item was changed:
----- Method: CoInterpreter>>primTraceLogAddress (in category 'cog jit support') -----
primTraceLogAddress
<api>
<returnTypeC: #'void *'>
+ ^self cCode: [primTraceLog] inSmalltalk: [primTraceLog offset * objectMemory wordSize]!
- ^self cCode: [primTraceLog] inSmalltalk: [primTraceLog offset * BytesPerWord]!
Item was changed:
----- Method: CoInterpreter>>printFrame:WithSP: (in category 'debug printing') -----
printFrame: theFP WithSP: theSP
<api>
| theMethod theMethodEnd numArgs numTemps rcvrAddress topThing |
<inline: false>
<var: #theFP type: #'char *'>
<var: #theSP type: #'char *'>
<var: #addr type: #'char *'>
<var: #rcvrAddress type: #'char *'>
<var: #cogMethod type: #'CogBlockMethod *'>
<var: #homeMethod type: #'CogMethod *'>
self cCode: '' inSmalltalk: [self transcript ensureCr].
(self isMachineCodeFrame: theFP)
ifTrue:
[| cogMethod homeMethod |
cogMethod := self mframeCogMethod: theFP.
homeMethod := self mframeHomeMethod: theFP.
theMethod := homeMethod asInteger.
theMethodEnd := homeMethod asInteger + homeMethod blockSize.
numArgs := cogMethod cmNumArgs.
numTemps := self temporaryCountOfMethodHeader: homeMethod methodHeader]
ifFalse:
[theMethod := self frameMethodObject: theFP.
theMethodEnd := theMethod + (objectMemory sizeBitsOfSafe: theMethod).
numArgs := self iframeNumArgs: theFP.
numTemps := self tempCountOf: theMethod].
(self frameIsBlockActivation: theFP) ifTrue:
[| rcvrOrClosure |
"No BlockLocalTempCounter in the Cogit's C code, so quick hack is to use numCopied + numArgs"
rcvrOrClosure := self pushedReceiverOrClosureOfFrame: theFP.
((objectMemory isNonImmediate: rcvrOrClosure)
and: [(objectMemory addressCouldBeObj: rcvrOrClosure)
and: [(objectMemory fetchClassOfNonImm: rcvrOrClosure) = (objectMemory splObj: ClassBlockClosure)]])
ifTrue: [numTemps := numArgs + (self stSizeOf: rcvrOrClosure)]
ifFalse: [numTemps := numArgs]].
self shortPrintFrame: theFP.
(self isBaseFrame: theFP) ifTrue:
[self printFrameOop: '(caller ctxt'
+ at: theFP + (self frameStackedReceiverOffset: theFP) + (2 * objectMemory wordSize).
- at: theFP + (self frameStackedReceiverOffset: theFP) + (2 * BytesPerWord).
self printFrameOop: '(saved ctxt'
+ at: theFP + (self frameStackedReceiverOffset: theFP) + (1 * objectMemory wordSize)].
- at: theFP + (self frameStackedReceiverOffset: theFP) + (1 * BytesPerWord)].
self printFrameOop: 'rcvr/clsr'
+ at: theFP + FoxCallerSavedIP + ((numArgs + 1) * objectMemory wordSize).
- at: theFP + FoxCallerSavedIP + ((numArgs + 1) * BytesPerWord).
numArgs to: 1 by: -1 do:
[:i|
+ self printFrameOop: 'arg' index: numArgs - i at: theFP + FoxCallerSavedIP + (i * objectMemory wordSize)].
- self printFrameOop: 'arg' index: numArgs - i at: theFP + FoxCallerSavedIP + (i * BytesPerWord)].
self printFrameThing: 'caller ip'
at: theFP + FoxCallerSavedIP
extraString: ((stackPages longAt: theFP + FoxCallerSavedIP) = cogit ceReturnToInterpreterPC ifTrue:
['ceReturnToInterpreter']).
self printFrameThing: 'saved fp' at: theFP + FoxSavedFP.
self printFrameMethodFor: theFP.
(self isMachineCodeFrame: theFP) ifTrue:
[self printFrameFlagsForFP: theFP].
self printFrameOop: 'context' at: theFP + FoxThisContext.
(self isMachineCodeFrame: theFP) ifFalse:
[self printFrameFlagsForFP: theFP].
(self isMachineCodeFrame: theFP)
ifTrue: [rcvrAddress := theFP + FoxMFReceiver]
ifFalse:
[self printFrameThing: 'saved ip'
at: theFP + FoxIFSavedIP
extra: ((self iframeSavedIP: theFP) = 0
ifTrue: [0]
+ ifFalse: [(self iframeSavedIP: theFP) - theMethod + 2 - objectMemory baseHeaderSize]).
- ifFalse: [(self iframeSavedIP: theFP) - theMethod + 2 - BaseHeaderSize]).
rcvrAddress := theFP + FoxIFReceiver].
self printFrameOop: 'receiver' at: rcvrAddress.
topThing := stackPages longAt: theSP.
(self oop: topThing isGreaterThanOrEqualTo: theMethod andLessThan: theMethodEnd)
ifTrue:
+ [rcvrAddress - objectMemory wordSize to: theSP + objectMemory wordSize by: objectMemory wordSize negated do:
- [rcvrAddress - BytesPerWord to: theSP + BytesPerWord by: BytesPerWord negated do:
[:addr| | index |
+ index := rcvrAddress - addr / objectMemory wordSize + numArgs.
- index := rcvrAddress - addr / BytesPerWord + numArgs.
index <= numTemps
ifTrue: [self printFrameOop: 'temp' index: index - 1 at: addr]
ifFalse: [self printFrameOop: ((self frameIsBlockActivation: theFP)
ifTrue: ['temp/stck']
ifFalse: ['stck'])
at: addr]].
self printFrameThing: 'frame ip'
at: theSP
extra: ((self isMachineCodeFrame: theFP)
ifTrue: [topThing - theMethod]
+ ifFalse: [topThing - theMethod + 2 - objectMemory baseHeaderSize])]
- ifFalse: [topThing - theMethod + 2 - BaseHeaderSize])]
ifFalse:
+ [rcvrAddress - objectMemory wordSize to: theSP by: objectMemory wordSize negated do:
- [rcvrAddress - BytesPerWord to: theSP by: BytesPerWord negated do:
[:addr| | index |
+ index := rcvrAddress - addr / objectMemory wordSize + numArgs.
- index := rcvrAddress - addr / BytesPerWord + numArgs.
index <= numTemps
ifTrue: [self printFrameOop: 'temp' index: index - 1 at: addr]
ifFalse: [self printFrameOop: ((self frameIsBlockActivation: theFP)
ifTrue: ['temp/stck']
ifFalse: ['stck'])
at: addr]]]!
Item was changed:
----- Method: CoInterpreter>>pushClosureNumArgs:copiedValues:blockSize: (in category 'stack bytecodes') -----
pushClosureNumArgs: numArgs copiedValues: numCopied blockSize: blockSize
"The compiler has pushed the values to be copied, if any.
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.
Override only to add debug tracing as of 4/26/2009"
<inline: true>
| newClosure context |
"No need to record the pushed copied values in the outerContext."
+ context := self ensureFrameIsMarried: localFP SP: localSP + (numCopied * objectMemory bytesPerOop).
- context := self ensureFrameIsMarried: localFP SP: localSP + (numCopied * BytesPerOop).
newClosure := self
closureIn: context
numArgs: numArgs
+ instructionPointer: (self oopForPointer: localIP) + 2 - (method+objectMemory baseHeaderSize)
- instructionPointer: (self oopForPointer: localIP) + 2 - (method+BaseHeaderSize)
numCopiedValues: numCopied.
cogit recordSendTrace ifTrue:
[self recordTrace: TraceBlockCreation thing: newClosure source: TraceIsFromInterpreter].
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: CoInterpreter>>readImageFromFile:HeapSize:StartingAt: (in category 'image save/restore') -----
readImageFromFile: f HeapSize: desiredHeapSize StartingAt: imageOffset
"Read an image from the given file stream, allocating the given amount of memory to its object heap. Fail if the image has an unknown format or requires more than the given amount of memory."
"Details: This method detects when the image was stored on a machine with the opposite byte ordering from this machine and swaps the bytes automatically. Furthermore, it allows the header information to start 512 bytes into the file, since some file transfer programs for the Macintosh apparently prepend a Mac-specific header of this size. Note that this same 512 bytes of prefix area could also be used to store an exec command on Unix systems, allowing one to launch Smalltalk by invoking the image name as a command."
"This code is based on C code by Ian Piumarta and Smalltalk code by Tim Rowledge. Many thanks to both of you!!!!"
| swapBytes headerStart headerSize dataSize oldBaseAddr
minimumMemory heapSize bytesRead bytesToShift firstSegSize
hdrNumStackPages hdrEdenBytes hdrCogCodeSize headerFlags hdrMaxExtSemTabSize |
<var: #f type: #sqImageFile>
<var: #heapSize type: #usqInt>
<var: #dataSize type: #'size_t'>
<var: #minimumMemory type: #usqInt>
<var: #desiredHeapSize type: #usqInt>
<var: #headerStart type: #squeakFileOffsetType>
<var: #imageOffset type: #squeakFileOffsetType>
metaclassNumSlots := 6. "guess Metaclass instSize"
classNameIndex := 6. "guess (Class instVarIndexFor: 'name' ifAbsent: []) - 1"
swapBytes := self checkImageVersionFrom: f startingAt: imageOffset.
+ headerStart := (self sqImageFilePosition: f) - objectMemory wordSize. "record header start position"
- headerStart := (self sqImageFilePosition: f) - BytesPerWord. "record header start position"
headerSize := self getLongFromFile: f swap: swapBytes.
dataSize := self getLongFromFile: f swap: swapBytes.
oldBaseAddr := self getLongFromFile: f swap: swapBytes.
objectMemory specialObjectsOop: (self getLongFromFile: f swap: swapBytes).
objectMemory lastHash: (self getLongFromFile: f swap: swapBytes). "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. "N.B. not used."
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.
"This slot holds the size of the native method zone in 1k units. (pad to word boundary)."
hdrCogCodeSize := (self getShortFromFile: f swap: swapBytes) * 1024.
cogCodeSize := desiredCogCodeSize ~= 0
ifTrue: [desiredCogCodeSize]
ifFalse:
[hdrCogCodeSize = 0
ifTrue: [self defaultCogCodeSize]
ifFalse: [hdrCogCodeSize]].
hdrEdenBytes := self getLongFromFile: f swap: swapBytes.
objectMemory edenBytes: (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].
"pad to word boundary. This slot can be used for anything else that will fit in 16 bits.
Preserve it to be polite to other VMs."
the2ndUnknownShort := self getShortFromFile: f swap: swapBytes.
firstSegSize := self getLongFromFile: f swap: swapBytes.
objectMemory firstSegmentSize: firstSegSize.
"compare memory requirements with availability"
minimumMemory := cogCodeSize "no need to include the stackZone; this is alloca'ed"
+ dataSize
+ objectMemory newSpaceBytes
+ self interpreterAllocationReserveBytes.
heapSize := cogCodeSize "no need to include the stackZone; this is alloca'ed"
+ desiredHeapSize
+ objectMemory newSpaceBytes
+ self interpreterAllocationReserveBytes.
heapSize < minimumMemory ifTrue:
[self insufficientMemorySpecifiedError].
"allocate a contiguous block of memory for the Squeak heap and ancilliary data structures"
objectMemory memory: (self
allocateMemory: heapSize
minimum: minimumMemory
imageFile: f
headerSize: headerSize) asUnsignedInteger.
objectMemory memory ifNil: [self insufficientMemoryAvailableError].
heapBase := objectMemory
setHeapBase: objectMemory memory + cogCodeSize
memoryLimit: objectMemory memory + heapSize
endOfMemory: objectMemory memory + cogCodeSize + 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 := objectMemory readHeapFromImageFile: f dataBytes: dataSize.
bytesRead ~= dataSize ifTrue: [self unableToReadImageError].
self ensureImageFormatIsUpToDate: swapBytes.
"compute difference between old and new memory base addresses"
bytesToShift := objectMemory memoryBaseForImageRead - oldBaseAddr.
self initializeInterpreter: bytesToShift. "adjusts all oops to new location"
self initializeCodeGenerator.
^dataSize!
Item was changed:
----- Method: CoInterpreter>>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
context (uninitialized?)
method header fields (interpreter only)
saved method ip (uninitialized?; interpreter only)
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:"
+ ^(IFrameSlots + 64) * objectMemory wordSize!
- ^(IFrameSlots + 64) * BytesPerWord!
Item was changed:
----- Method: CoInterpreter>>stackPointerIndexForFrame:WithSP: (in category 'frame access') -----
stackPointerIndexForFrame: theFP WithSP: theSP
"Return the 1-based index rel to the given frame"
"In the StackInterpreter stacks grow down."
^(self isMachineCodeFrame: theFP)
+ ifTrue: [(((theFP + FoxMFReceiver) - theSP) >> objectMemory shiftForWord) + (self mframeNumArgs: theFP)]
+ ifFalse: [(((theFP + FoxIFReceiver) - theSP) >> objectMemory shiftForWord) + (self iframeNumArgs: theFP)]!
- ifTrue: [(((theFP + FoxMFReceiver) - theSP) >> ShiftForWord) + (self mframeNumArgs: theFP)]
- ifFalse: [(((theFP + FoxIFReceiver) - theSP) >> ShiftForWord) + (self iframeNumArgs: theFP)]!
Item was changed:
----- Method: CoInterpreter>>stackPointerIndexForIFrame:WithSP:numArgs: (in category 'frame access') -----
stackPointerIndexForIFrame: theFP WithSP: theSP numArgs: numArgs
"Return the 1-based index rel to the given frame"
"In the StackInterpreter stacks grow down."
+ ^(((theFP + FoxIFReceiver) - theSP) >> objectMemory shiftForWord) + numArgs!
- ^(((theFP + FoxIFReceiver) - theSP) >> ShiftForWord) + numArgs!
Item was changed:
----- Method: CoInterpreter>>stackPointerIndexForMFrame:WithSP:numArgs: (in category 'frame access') -----
stackPointerIndexForMFrame: theFP WithSP: theSP numArgs: numArgs
"Return the 1-based index rel to the given machine code frame"
"In the StackInterpreter stacks grow down."
+ ^(((theFP + FoxMFReceiver) - theSP) >> objectMemory shiftForWord) + numArgs!
- ^(((theFP + FoxMFReceiver) - theSP) >> ShiftForWord) + numArgs!
Item was changed:
----- Method: CoInterpreter>>temporary:in: (in category 'internal interpreter access') -----
temporary: offset in: theFP
"See StackInterpreter class>>initializeFrameIndices"
| frameNumArgs |
<inline: true>
<var: #theFP type: #'char *'>
^(self isMachineCodeFrame: theFP)
ifTrue:
[offset < (frameNumArgs := self mframeNumArgs: theFP)
+ ifTrue: [stackPages longAt: theFP + FoxCallerSavedIP + ((frameNumArgs - offset) * objectMemory wordSize)]
+ ifFalse: [stackPages longAt: theFP + FoxMFReceiver - objectMemory wordSize + ((frameNumArgs - offset) * objectMemory wordSize)]]
- ifTrue: [stackPages longAt: theFP + FoxCallerSavedIP + ((frameNumArgs - offset) * BytesPerWord)]
- ifFalse: [stackPages longAt: theFP + FoxMFReceiver - BytesPerWord + ((frameNumArgs - offset) * BytesPerWord)]]
ifFalse:
[self itemporary: offset in: theFP]!
Item was changed:
----- Method: CoInterpreter>>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) * objectMemory wordSize)]
- ifTrue: [theFP + FoxCallerSavedIP + ((numArgs - offset) * BytesPerWord)]
ifFalse: [theFP
+ ((self isMachineCodeFrame: theFP)
+ ifTrue: [FoxMFReceiver - objectMemory wordSize]
+ ifFalse: [FoxIFReceiver - objectMemory wordSize])
+ + ((numArgs - offset) * objectMemory wordSize)]!
- ifTrue: [FoxMFReceiver - BytesPerWord]
- ifFalse: [FoxIFReceiver - BytesPerWord])
- + ((numArgs - offset) * BytesPerWord)]!
Item was changed:
----- Method: CoInterpreter>>transferTo:from: (in category 'process primitive support') -----
transferTo: newProc from: sourceCode
"Record a process to be awoken on the next interpreter cycle.
Reimplement to record the source of the switch for debugging,
and to cope with possible code compaction in makeBaseFrameFor:."
| activeContext sched oldProc |
<inline: false>
self recordContextSwitchFrom: self activeProcess in: sourceCode.
statProcessSwitch := statProcessSwitch + 1.
self push: instructionPointer.
self externalWriteBackHeadFramePointers.
self assertValidExecutionPointe: instructionPointer r: framePointer s: stackPointer.
"ensureMethodIsCogged: in makeBaseFrameFor: in
externalSetStackPageAndPointersForSuspendedContextOfProcess:
below may do a code compaction. Nil instructionPointer to avoid it getting pushed twice."
instructionPointer := 0.
sched := self schedulerPointer.
oldProc := objectMemory fetchPointer: ActiveProcessIndex ofObject: sched.
+ activeContext := self ensureFrameIsMarried: framePointer SP: stackPointer + objectMemory wordSize.
- activeContext := self ensureFrameIsMarried: framePointer SP: stackPointer + BytesPerWord.
objectMemory storePointer: SuspendedContextIndex ofObject: oldProc withValue: activeContext.
objectMemory storePointer: ActiveProcessIndex ofObject: sched withValue: newProc.
objectMemory storePointerUnchecked: MyListIndex ofObject: newProc withValue: objectMemory nilObject.
self externalSetStackPageAndPointersForSuspendedContextOfProcess: newProc!
Item was changed:
----- Method: CoInterpreter>>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 argsPointer |
<inline: false>
<var: #theFP type: #'char *'>
<var: #theSP type: #'char *'>
<var: #pointer type: #'char *'>
<var: #argsPointer type: #'char *'>
self assert: (self frameHasContext: theFP).
theContext := self frameContext: theFP.
self assert: (objectMemory isContext: theContext).
self assert: (self frameReceiver: theFP)
= (objectMemory noFixupFollowField: ReceiverIndex ofObject: theContext).
(self isMachineCodeFrame: theFP)
ifTrue:
[tempIndex := self mframeNumArgs: theFP.
+ pointer := theFP + FoxMFReceiver - objectMemory wordSize]
- pointer := theFP + FoxMFReceiver - BytesPerWord]
ifFalse:
[tempIndex := self iframeNumArgs: theFP.
+ pointer := theFP + FoxIFReceiver - objectMemory wordSize].
- pointer := theFP + FoxIFReceiver - BytesPerWord].
"update the arguments. this would appear not to be strictly necessary, but is for two reasons.
First, the fact that arguments are read-only is only as convention in the Smalltalk compiler;
other languages may choose to modify arguments.
Second, the Squeak runUntilErrorOrReturnFrom: nightmare pops the stack top, which may, in
certain circumstances, be the last argument, and hence the last argument may not have been
stored into the context."
argsPointer := theFP + (self frameStackedReceiverOffsetNumArgs: tempIndex).
1 to: tempIndex do:
[:i|
+ argsPointer := argsPointer - objectMemory wordSize.
- argsPointer := argsPointer - BytesPerWord.
self assert: (objectMemory addressCouldBeOop: (stackPages longAt: argsPointer)).
objectMemory storePointer: ReceiverIndex + i
ofObject: theContext
withValue: (stackPages longAt: argsPointer)].
"now update the non-argument stack contents."
[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 - objectMemory wordSize].
- pointer := pointer - BytesPerWord].
self assert: ReceiverIndex + tempIndex < (objectMemory lengthOf: theContext).
objectMemory storePointerUnchecked: StackPointerIndex
ofObject: theContext
withValue: (objectMemory integerObjectOf: tempIndex)!
Item was changed:
----- Method: CoInterpreter>>validStackPageBaseFrame: (in category 'stack pages') -----
validStackPageBaseFrame: aPage
"Check that the base frame in the stack page has a valid sender and saved context."
<var: #aPage type: #'StackPage *'>
<inline: false>
| savedThisContext senderContextOrNil |
senderContextOrNil := stackPages longAt: aPage baseAddress.
+ savedThisContext := stackPages longAt: aPage baseAddress - objectMemory wordSize.
+ (self asserta: aPage baseFP + (self frameStackedReceiverOffset: aPage baseFP) + (2 * objectMemory wordSize) = aPage baseAddress) ifFalse:
- savedThisContext := stackPages longAt: aPage baseAddress - BytesPerWord.
- (self asserta: aPage baseFP + (self frameStackedReceiverOffset: aPage baseFP) + (2 * BytesPerWord) = aPage baseAddress) ifFalse:
[^false].
(self asserta: (objectMemory addressCouldBeObj: senderContextOrNil)) ifFalse:
[^false].
(self asserta: (objectMemory addressCouldBeObj: savedThisContext)) ifFalse:
[^false].
(self asserta: (senderContextOrNil = objectMemory nilObject or: [objectMemory isContext: senderContextOrNil])) ifFalse:
[^false].
(self asserta: (objectMemory isContext: savedThisContext)) ifFalse:
[^false].
(self asserta: (self frameCallerContext: aPage baseFP) = senderContextOrNil) ifFalse:
[^false].
(self asserta: (self frameContext: aPage baseFP) = savedThisContext) ifFalse:
[^false].
^true!
Item was changed:
----- Method: CoInterpreterPrimitives>>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.
Override to ensure the caller's saved ip is correct, i.e. if an interpreter frame it may
have to move to iframeSavedIP."
| 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: [objectMemory 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 assertValidStackedInstructionPointersIn: stackPage line: #'__LINE__'.
(self frameCallerFP: theFP) ~= contextsFP ifTrue:
[stackedReceiverOffset := self frameStackedReceiverOffset: theFP.
frameAbove := self findFrameAbove: contextsFP inPage: pageToStopOn.
contextsIP := (self frameCallerSavedIP: frameAbove) asUnsignedInteger.
self assert: ((contextsIP asUnsignedInteger >= objectMemory startOfMemory)
or: [contextsIP = cogit ceReturnToInterpreterPC]) == (self isMachineCodeFrame: contextsFP) not.
newSP := self frameCallerSP: frameAbove.
+ newFP := newSP - stackedReceiverOffset - objectMemory wordSize.
- newFP := newSP - stackedReceiverOffset - BytesPerWord.
theFP + stackedReceiverOffset
to: stackPointer
+ by: objectMemory wordSize negated
- by: BytesPerWord negated
do: [:source|
+ newSP := newSP - objectMemory wordSize.
- newSP := newSP - BytesPerWord.
stackPages longAt: newSP put: (stackPages longAt: source)].
stackPages longAt: newFP + FoxSavedFP put: contextsFP.
"Ensure contract between machine-code callee and interpreter caller frames is preserved.
Return pc needs to be ceReturnToInterpreterPC."
((self isMachineCodeFrame: newFP)
and: [contextsIP >= objectMemory startOfMemory]) ifTrue:
[self iframeSavedIP: contextsFP put: contextsIP.
contextsIP := cogit ceReturnToInterpreterPC].
stackPages longAt: newFP + FoxCallerSavedIP put: contextsIP.
self assert: (objectMemory 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 assertValidStackedInstructionPointersIn: stackPage line: #'__LINE__'.
self assert: stackPage = stackPages mostRecentlyUsedPage.
^nil].
self assertValidStackedInstructionPointers: #'__LINE__'.
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 assertValidStackedInstructionPointers: #'__LINE__'.
(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: (objectMemory 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) - objectMemory wordSize.
- [contextsSP := (self frameCallerSP: frameAbove) - 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 assertValidStackedInstructionPointers: #'__LINE__'.
self assert: stackPage = stackPages mostRecentlyUsedPage!
Item was changed:
----- Method: CoInterpreterStackPages>>couldBeFramePointer: (in category 'assertions') -----
couldBeFramePointer: pointer
"Answer if the argument is a properly aligned pointer into the stack zone."
<var: #pointer type: #'void *'>
+ ^(pointer asUnsignedInteger bitAnd: objectMemory wordSize - 1) = 0
- ^(pointer asUnsignedInteger bitAnd: BytesPerWord - 1) = 0
and: [pointer asUnsignedInteger
between: (stackBasePlus1 - 1) asUnsignedInteger
and: (self cCode: [pages asUnsignedInteger]
inSmalltalk: [(self stackPageAt: 0) asUnsignedInteger])]!
Item was changed:
----- Method: CoInterpreterStackPages>>extraStackBytes (in category 'initialization') -----
extraStackBytes
"See initializeStack:numSlots:pageSize:stackLimitOffset:stackPageHeadroom:
``Because stack pages grow down...''"
+ ^objectMemory wordSize!
- ^BytesPerWord!
Item was changed:
----- Method: CoInterpreterStackPages>>initializeStack:numSlots:pageSize: (in category 'initialization') -----
initializeStack: theStackPages numSlots: stackSlots pageSize: slotsPerPage
"Initialize the stack pages. In the C VM theStackPages will be alloca'ed memory to hold the
stack pages on the C stack. In the simulator they are housed in the memory between the
cogMethodZone and the heap."
<var: #theStackPages type: #'char *'>
<returnTypeC: #void>
| numPages page structStackPageSize pageStructBase count |
<var: #page type: #'StackPage *'>
<var: #pageStructBase type: #'char *'>
self cCode: []
inSmalltalk:
[self assert: objectMemory startOfMemory - coInterpreter cogCodeSize - Cogit guardPageSize - coInterpreter methodCacheSize - coInterpreter primTraceLogSize - coInterpreter rumpCStackSize
+ = (stackSlots * objectMemory wordSize roundUpTo: objectMemory allocationUnit)].
- = (stackSlots * BytesPerWord roundUpTo: objectMemory allocationUnit)].
structStackPageSize := coInterpreter sizeof: InterpreterStackPage.
+ bytesPerPage := slotsPerPage * objectMemory wordSize.
- bytesPerPage := slotsPerPage * BytesPerWord.
numPages := coInterpreter numStkPages.
"Because stack pages grow down baseAddress is at the top of a stack page and so to avoid
subtracting BytesPerWord from baseAddress and lastAddress in the init loop below we simply
push the stackPage array up one word to avoid the overlap. This word is extraStackBytes."
+ pageStructBase := theStackPages + (numPages * bytesPerPage) + objectMemory wordSize.
- pageStructBase := theStackPages + (numPages * bytesPerPage) + BytesPerWord.
pages := self cCode: [self cCoerceSimple: pageStructBase to: #'StackPage *']
inSmalltalk:
[pageMap := Dictionary new.
((0 to: numPages - 1) collect:
[:i|
InterpreterStackPage surrogateClass new
address: pageStructBase + (i * structStackPageSize)
simulator: coInterpreter
zoneBase: coInterpreter stackZoneBase
zoneLimit: objectMemory startOfMemory])
do: [:pageSurrogate|
pageMap at: pageSurrogate address put: pageSurrogate];
yourself].
"make sure there's enough headroom"
self assert: coInterpreter stackPageByteSize - coInterpreter stackLimitBytes - coInterpreter stackLimitOffset
>= coInterpreter stackPageHeadroom.
0 to: numPages - 1 do:
[:index|
page := self stackPageAt: index.
page
lastAddress: theStackPages + (index * bytesPerPage);
baseAddress: page lastAddress + bytesPerPage;
stackLimit: page baseAddress - coInterpreter stackLimitBytes;
realStackLimit: page stackLimit;
baseFP: 0;
nextPage: (self stackPageAt: (index = (numPages - 1) ifTrue: [0] ifFalse: [index + 1]));
prevPage: (self stackPageAt: (index = 0 ifTrue: [numPages - 1] ifFalse: [index - 1]))].
"Now compute stackBasePlus1 so that the pageIndexFor: call maps all addresses from
aPage baseAddress to aBase limitAddress + 1 to the same index (stacks grow down)"
stackBasePlus1 := (self cCoerceSimple: theStackPages to: #'char *') + 1.
self cCode: []
inSmalltalk:
[minStackAddress := theStackPages.
+ maxStackAddress := theStackPages + (numPages * bytesPerPage) + objectMemory wordSize - 1].
- maxStackAddress := theStackPages + (numPages * bytesPerPage) + BytesPerWord - 1].
"The overflow limit is the amount of stack to retain when moving frames from an overflowing
stack to reduce thrashing. See stackOverflowOrEvent:mayContextSwitch:"
page := self stackPageAt: 0.
overflowLimit := page baseAddress - page realStackLimit * 3 // 5.
0 to: numPages - 1 do:
[:index|
page := self stackPageAt: index.
self assert: (self pageIndexFor: page baseAddress) == index.
+ self assert: (self pageIndexFor: page baseAddress - (slotsPerPage - 1 * objectMemory wordSize)) == index.
- self assert: (self pageIndexFor: page baseAddress - (slotsPerPage - 1 * BytesPerWord)) == index.
self assert: (self stackPageFor: page baseAddress) == page.
self assert: (self stackPageFor: page stackLimit) == page.
self cCode: []
inSmalltalk:
[| memIndex |
memIndex := index * slotsPerPage + 1. "this is memIndex in the block above"
self assert: (self memIndexFor: (self oopForPointer: page baseAddress))
== (memIndex + slotsPerPage - 1).
index < (numPages - 1) ifTrue:
+ [self assert: (self stackPageFor: page baseAddress + objectMemory wordSize) == (self stackPageAt: index + 1)]].
- [self assert: (self stackPageFor: page baseAddress + BytesPerWord) == (self stackPageAt: index + 1)]].
coInterpreter initializePageTraceToInvalid: page].
mostRecentlyUsedPage := self stackPageAt: 0.
page := mostRecentlyUsedPage.
count := 0.
[| theIndex |
count := count + 1.
theIndex := self pageIndexFor: page baseAddress.
self assert: (self stackPageAt: theIndex) == page.
self assert: (self pageIndexFor: page baseAddress) == theIndex.
self assert: (self pageIndexFor: page stackLimit) == theIndex.
self assert: (self pageIndexFor: page lastAddress + 1) == theIndex.
(page := page nextPage) ~= mostRecentlyUsedPage] whileTrue.
self assert: count == numPages.
self assert: self pageListIsWellFormed!
Item was changed:
----- Method: CoInterpreterStackPages>>longAt: (in category 'memory access') -----
longAt: byteAddress
+ <doNotGenerate>
"Note: Adjusted for Smalltalk's 1-based array indexing."
self assert: (byteAddress >= minStackAddress and: [byteAddress < maxStackAddress]).
^objectMemory longAt: byteAddress!
Item was changed:
----- Method: CoInterpreterStackPages>>longAt:put: (in category 'memory access') -----
longAt: byteAddress put: a32BitValue
+ <doNotGenerate>
self assert: (byteAddress >= minStackAddress and: [byteAddress < maxStackAddress]).
^objectMemory longAt: byteAddress put: a32BitValue!
Item was changed:
----- Method: CoInterpreterStackPages>>markStackPageMostRecentlyUsed: (in category 'page access') -----
markStackPageMostRecentlyUsed: page "<InterpreterStackPage>"
"MRUP-->used page<->used page<->used page<->used page<--LRUP
^ <-next-prev-> ^
| |
v <-prev-next-> v
free page<->free page<->free page<->free page"
<var: #page type: #'StackPage *'>
- <asmLabel: false>
<returnTypeC: #void>
page == mostRecentlyUsedPage ifTrue:
[^nil].
"Common case; making new page most recently used."
page prevPage == mostRecentlyUsedPage ifTrue:
[mostRecentlyUsedPage := page.
self assert: self pageListIsWellFormed.
^nil].
page prevPage nextPage: page nextPage.
page nextPage prevPage: page prevPage.
mostRecentlyUsedPage nextPage prevPage: page.
page prevPage: mostRecentlyUsedPage.
page nextPage: mostRecentlyUsedPage nextPage.
mostRecentlyUsedPage nextPage: page.
mostRecentlyUsedPage := page.
self assert: self pageListIsWellFormed!
Item was changed:
----- Method: CoInterpreterStackPages>>memIndexFor: (in category 'page access') -----
memIndexFor: byteAddress
+ ^(self oopForPointer: byteAddress) - coInterpreter stackZoneBase - 1 // objectMemory wordSize + 1!
- ^(self oopForPointer: byteAddress) - coInterpreter stackZoneBase - 1 // BytesPerWord + 1!
Item was added:
+ ----- Method: CoInterpreterStackPages>>pages (in category 'accessing') -----
+ pages
+ <doNotGenerate>
+ ^pages!
Item was added:
+ ----- Method: CoInterpreterStackPages>>setInterpreter: (in category 'initialization') -----
+ setInterpreter: anInterpreter
+ "Initialize the stackPages memory for simulation. To keep access monitoring
+ in one place we defer to the coInterpreter for accessing memory."
+ <doNotGenerate>
+ coInterpreter := anInterpreter.
+ objectMemory := coInterpreter objectMemory!
Item was added:
+ ----- Method: CoInterpreterStackPages>>surrogateAtAddress: (in category 'accessing') -----
+ surrogateAtAddress: anAddress
+ <doNotGenerate>
+ ^pageMap at: anAddress!
Item was changed:
+ CoInterpreterStackPages subclass: #CoInterpreterStackPagesLSB
- CoInterpreterStackPagesSimulator subclass: #CoInterpreterStackPagesLSB
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'VMMaker-JITSimulation'!
Item was changed:
+ CoInterpreterStackPages subclass: #CoInterpreterStackPagesMSB
- CoInterpreterStackPagesSimulator subclass: #CoInterpreterStackPagesMSB
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'VMMaker-JITSimulation'!
Item was removed:
- CoInterpreterStackPages subclass: #CoInterpreterStackPagesSimulator
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'VMMaker-JITSimulation'!
-
- !CoInterpreterStackPagesSimulator commentStamp: '<historical>' prior: 0!
- I am a class that helps simulate the StackInterpreter's stack organization.!
Item was removed:
- ----- Method: CoInterpreterStackPagesSimulator>>pages (in category 'accessing') -----
- pages
- ^pages!
Item was removed:
- ----- Method: CoInterpreterStackPagesSimulator>>surrogateAtAddress: (in category 'accessing') -----
- surrogateAtAddress: anAddress
- ^pageMap at: anAddress!
Item was changed:
----- Method: CoInterpreterTests>>testMinimumUnusedHeadroom (in category 'tests') -----
testMinimumUnusedHeadroom
"self new testMinimumUnusedHeadroom"
+ | ci bpw |
- | ci |
CoInterpreter initializeWithOptions: Dictionary new.
ci := CogVMSimulator new.
+ bpw := ci objectMemory bytesPerWord.
ci initStackPagesForTests.
self assert: ci minimumUnusedHeadroom = ci stackPageByteSize.
+ 0 to: ci stackPageByteSize - 1 by: bpw do:
- 0 to: ci stackPageByteSize - 1 by: BytesPerWord do:
[:p|
0 to: ci numStackPages - 1 do:
[:i| | page |
page := ci stackPages stackPageAt: i.
ci longAt: page baseAddress - p put: 1].
+ self assert: ci minimumUnusedHeadroom = (ci stackPageByteSize - (p + bpw))]!
- self assert: ci minimumUnusedHeadroom = (ci stackPageByteSize - (p + BytesPerWord))]!
Item was changed:
----- Method: CogIA32Compiler>>genPushRegisterArgsForAbortMissNumArgs: (in category 'smalltalk calling convention') -----
genPushRegisterArgsForAbortMissNumArgs: numArgs
"Ensure that the register args are pushed before the outer and
inner retpcs at an entry miss for arity <= self numRegArgs. The
outer retpc is that of a call at a send site. The inner is the call
from a method or PIC abort/miss to the trampoline."
"This won't be as clumsy on a RISC. But putting the receiver and
args above the return address means the CoInterpreter has a
single machine-code frame format which saves us a lot of work."
"Iff there are register args convert
base -> outerRetpc (send site retpc)
sp -> innerRetpc (PIC abort/miss retpc)
to
base -> receiver
(arg0)
(arg1)
outerRetpc
sp -> innerRetpc (PIC abort/miss retpc)"
numArgs <= cogit numRegArgs ifTrue:
[self assert: cogit numRegArgs <= 2.
numArgs = 0 ifTrue:
[cogit MoveMw: 0 r: SPReg R: TempReg.
cogit PushR: TempReg.
+ cogit MoveMw: objectMemory wordSize * 2 r: SPReg R: TempReg.
+ cogit MoveR: TempReg Mw: objectMemory wordSize r: SPReg.
+ cogit MoveR: ReceiverResultReg Mw: 2 * objectMemory wordSize r: SPReg.
- cogit MoveMw: BytesPerWord * 2 r: SPReg R: TempReg.
- cogit MoveR: TempReg Mw: BytesPerWord r: SPReg.
- cogit MoveR: ReceiverResultReg Mw: 2 * BytesPerWord r: SPReg.
^self].
numArgs = 1 ifTrue:
+ [cogit MoveMw: objectMemory wordSize r: SPReg R: TempReg.
- [cogit MoveMw: BytesPerWord r: SPReg R: TempReg.
cogit PushR: TempReg.
+ cogit MoveMw: objectMemory wordSize r: SPReg R: TempReg.
- cogit MoveMw: BytesPerWord r: SPReg R: TempReg.
cogit PushR: TempReg.
+ cogit MoveR: ReceiverResultReg Mw: 3 * objectMemory wordSize r: SPReg.
+ cogit MoveR: Arg0Reg Mw: 2 * objectMemory wordSize r: SPReg.
- cogit MoveR: ReceiverResultReg Mw: 3 * BytesPerWord r: SPReg.
- cogit MoveR: Arg0Reg Mw: 2 * BytesPerWord r: SPReg.
^self].
numArgs = 2 ifTrue:
[cogit PushR: Arg1Reg.
+ cogit MoveMw: objectMemory wordSize * 2 r: SPReg R: TempReg.
- cogit MoveMw: BytesPerWord * 2 r: SPReg R: TempReg.
cogit PushR: TempReg.
+ cogit MoveMw: objectMemory wordSize * 2 r: SPReg R: TempReg.
- cogit MoveMw: BytesPerWord * 2 r: SPReg R: TempReg.
cogit PushR: TempReg.
+ cogit MoveR: ReceiverResultReg Mw: 4 * objectMemory wordSize r: SPReg.
+ cogit MoveR: Arg0Reg Mw: 3 * objectMemory wordSize r: SPReg.
- cogit MoveR: ReceiverResultReg Mw: 4 * BytesPerWord r: SPReg.
- cogit MoveR: Arg0Reg Mw: 3 * BytesPerWord r: SPReg.
^self]]!
Item was changed:
----- Method: CogIA32Compiler>>genPushRegisterArgsForNumArgs: (in category 'smalltalk calling convention') -----
genPushRegisterArgsForNumArgs: numArgs
"Ensure that the register args are pushed before the retpc for arity <= self numRegArgs."
"This won't be as clumsy on a RISC. But putting the receiver and
args above the return address means the CoInterpreter has a
single machine-code frame format which saves us a lot of work."
numArgs <= cogit numRegArgs ifTrue:
[self assert: cogit numRegArgs <= 2.
false "these two variants show the same performance on Intel Core i7, but the second one may be shorter."
ifTrue:
[cogit MoveMw: 0 r: SPReg R: TempReg. "Save return address"
numArgs > 0 ifTrue:
[cogit PushR: Arg0Reg.
numArgs > 1 ifTrue:
[cogit PushR: Arg1Reg]].
cogit PushR: TempReg.
+ cogit MoveR: ReceiverResultReg Mw: objectMemory wordSize * (1 + numArgs) r: SPReg]
- cogit MoveR: ReceiverResultReg Mw: BytesPerWord * (1 + numArgs) r: SPReg]
ifFalse:
[cogit MoveMw: 0 r: SPReg R: TempReg. "Save return address"
cogit MoveR: ReceiverResultReg Mw: 0 r: SPReg.
numArgs > 0 ifTrue:
[cogit PushR: Arg0Reg.
numArgs > 1 ifTrue:
[cogit PushR: Arg1Reg]].
cogit PushR: TempReg]] "Restore return address"!
Item was changed:
----- Method: CogMethodSurrogate32 class>>offsetOf: (in category 'accessing') -----
offsetOf: aByteSymbol
"These should be generated!!!!"
+ | baseHeaderSize |
+ baseHeaderSize := self objectMemoryClass baseHeaderSize.
- self assert: self objectMemoryClass baseHeaderSize = BaseHeaderSize.
^aByteSymbol caseOf:
+ { [#methodObject] -> [8 + baseHeaderSize].
+ [#selector] -> [16 + baseHeaderSize].
+ [#blockEntryOffset] -> [6 + baseHeaderSize].
- { [#methodObject] -> [8 + BaseHeaderSize].
- [#selector] -> [16 + BaseHeaderSize].
- [#blockEntryOffset] -> [6 + BaseHeaderSize].
}!
Item was changed:
----- Method: CogMethodSurrogate64 class>>offsetOf: (in category 'accessing') -----
offsetOf: aByteSymbol
"These should be generated!!!!"
+ | baseHeaderSize |
+ baseHeaderSize := self objectMemoryClass baseHeaderSize.
- self assert: self objectMemoryClass baseHeaderSize = BaseHeaderSize.
^aByteSymbol caseOf:
+ { [#methodObject] -> [8 + baseHeaderSize].
+ [#selector] -> [24 + baseHeaderSize].
+ [#blockEntryOffset] -> [6 + baseHeaderSize].
- { [#methodObject] -> [8 + BaseHeaderSize].
- [#selector] -> [24 + BaseHeaderSize].
- [#blockEntryOffset] -> [6 + BaseHeaderSize].
}!
Item was changed:
----- Method: CogMethodZone>>addToYoungReferrers: (in category 'young referers') -----
addToYoungReferrers: cogMethod
<var: #cogMethod type: #'CogMethod *'>
self assert: youngReferrers <= limitAddress.
self assert: (self occurrencesInYoungReferrers: cogMethod) = 0.
self assert: cogMethod cmRefersToYoung.
self assert: (youngReferrers <= limitAddress
+ and: [youngReferrers >= (limitAddress - (methodCount * objectMemory wordSize))]).
+ (self asserta: limitAddress - (methodCount * objectMemory wordSize) >= mzFreeStart) ifFalse:
- and: [youngReferrers >= (limitAddress - (methodCount * BytesPerWord))]).
- (self asserta: limitAddress - (methodCount * BytesPerWord) >= mzFreeStart) ifFalse:
[self error: 'no room on youngReferrers list'].
+ youngReferrers := youngReferrers - objectMemory wordSize.
- youngReferrers := youngReferrers - BytesPerWord.
objectMemory longAt: youngReferrers put: cogMethod asUnsignedInteger!
Item was changed:
----- Method: CogMethodZone>>allocate: (in category 'allocating') -----
allocate: numBytes
| roundedBytes allocation |
roundedBytes := numBytes + 7 bitAnd: -8.
+ mzFreeStart + roundedBytes >= (limitAddress - (methodCount * objectMemory wordSize)) ifTrue:
- mzFreeStart + roundedBytes >= (limitAddress - (methodCount * BytesPerWord)) ifTrue:
[^0].
allocation := mzFreeStart.
mzFreeStart := mzFreeStart + roundedBytes.
methodCount := methodCount + 1.
self cCode: '' inSmalltalk:
[(cogit breakPC isInteger
and: [cogit breakPC between: allocation and: mzFreeStart]) ifTrue:
[cogit singleStep: true]].
^allocation!
Item was changed:
----- Method: CogMethodZone>>kosherYoungReferrers (in category 'young referers') -----
kosherYoungReferrers
"Answer that all entries in youngReferrers are in-use and have the cmRefersToYoung flag set.
Used to check that the youngreferrers pruning routines work correctly."
| pointer cogMethod |
<var: #pointer type: #usqInt>
<var: #cogMethod type: #'CogMethod *'>
(youngReferrers > limitAddress
or: [youngReferrers < mzFreeStart]) ifTrue:
[^false].
pointer := youngReferrers.
[pointer < limitAddress] whileTrue:
[cogMethod := coInterpreter cCoerceSimple: (objectMemory longAt: pointer) to: #'CogMethod *'.
(cogMethod cmType ~= CMFree and: [cogMethod cmRefersToYoung]) ifFalse:
[^false].
+ pointer := pointer + objectMemory wordSize].
- pointer := pointer + BytesPerWord].
^true!
Item was changed:
----- Method: CogMethodZone>>occurrencesInYoungReferrers: (in category 'young referers') -----
occurrencesInYoungReferrers: cogMethod
<var: #cogMethod type: #'CogMethod *'>
| count pointer |
<var: #pointer type: #usqInt>
self assert: youngReferrers <= limitAddress.
count := 0.
pointer := youngReferrers.
[pointer < limitAddress] whileTrue:
[cogMethod asInteger = (objectMemory longAt: pointer) ifTrue:
[count := count + 1].
+ pointer := pointer + objectMemory wordSize].
- pointer := pointer + BytesPerWord].
^count!
Item was changed:
----- Method: CogMethodZone>>printCogYoungReferrers (in category 'printing') -----
printCogYoungReferrers
<api>
<returnTypeC: #void>
| pointer cogMethod |
<var: #cogMethod type: #'CogMethod *'>
pointer := youngReferrers.
[pointer < limitAddress] whileTrue:
[cogMethod := coInterpreter cCoerceSimple: (objectMemory longAt: pointer) to: #'CogMethod *'.
cogMethod cmRefersToYoung ifFalse:
[coInterpreter print: '*'].
cogMethod cmType = CMFree ifTrue:
[coInterpreter print: '!!'].
(cogMethod cmRefersToYoung and: [cogMethod cmType ~= CMFree]) ifFalse:
[coInterpreter print: ' '].
coInterpreter printCogMethod: cogMethod.
+ pointer := pointer + objectMemory wordSize]!
- pointer := pointer + BytesPerWord]!
Item was changed:
----- Method: CogMethodZone>>pruneYoungReferrers (in category 'young referers') -----
pruneYoungReferrers
| source dest next |
<var: #source type: #usqInt>
<var: #dest type: #usqInt>
<var: #next type: #usqInt>
<inline: false>
self assert: youngReferrers <= limitAddress.
youngReferrers = limitAddress ifTrue:
[^nil].
dest := limitAddress.
+ [next := dest - objectMemory wordSize.
- [next := dest - BytesPerWord.
next >= youngReferrers
and: [(coInterpreter cCoerceSimple: (objectMemory longAt: next) to: #'CogMethod *') cmRefersToYoung]] whileTrue:
[dest := next].
self assert: dest >= youngReferrers.
+ source := dest - objectMemory wordSize.
- source := dest - BytesPerWord.
[source >= youngReferrers] whileTrue:
[(coInterpreter cCoerceSimple: (objectMemory longAt: source) to: #'CogMethod *') cmRefersToYoung ifTrue:
+ [self assert: source < (dest - objectMemory wordSize).
+ objectMemory longAt: (dest := dest - objectMemory wordSize) put: (objectMemory longAt: source)].
+ source := source - objectMemory wordSize].
- [self assert: source < (dest - BytesPerWord).
- objectMemory longAt: (dest := dest - BytesPerWord) put: (objectMemory longAt: source)].
- source := source - BytesPerWord].
youngReferrers := dest.
self assert: self kosherYoungReferrers!
Item was changed:
----- Method: CogMethodZone>>relocateAndPruneYoungReferrers (in category 'young referers') -----
relocateAndPruneYoungReferrers
| source dest next cogMethod |
<var: #source type: #usqInt>
<var: #dest type: #usqInt>
<var: #next type: #usqInt>
<var: #cogMethod type: #'CogMethod *'>
<inline: false>
self assert: youngReferrers <= limitAddress.
youngReferrers = limitAddress ifTrue:
[^nil].
dest := limitAddress.
+ [next := dest - objectMemory wordSize.
- [next := dest - BytesPerWord.
next >= youngReferrers
and: [(cogMethod := coInterpreter cCoerceSimple: (objectMemory longAt: next) to: #'CogMethod *') cmType ~= CMFree
and: [cogMethod cmRefersToYoung]]] whileTrue:
[cogMethod objectHeader ~= 0 ifTrue:
[coInterpreter longAt: next put: cogMethod asInteger + cogMethod objectHeader].
dest := next].
self assert: dest >= youngReferrers.
+ source := dest - objectMemory wordSize.
- source := dest - BytesPerWord.
[source >= youngReferrers] whileTrue:
[cogMethod := coInterpreter cCoerceSimple: (objectMemory longAt: source) to: #'CogMethod *'.
(cogMethod cmType ~= CMFree
and: [cogMethod cmRefersToYoung]) ifTrue:
+ [self assert: source < (dest - objectMemory wordSize).
- [self assert: source < (dest - BytesPerWord).
cogMethod objectHeader ~= 0 ifTrue:
[cogMethod := coInterpreter
cCoerceSimple: cogMethod asInteger + cogMethod objectHeader asInteger
to: #'CogMethod *'].
+ objectMemory longAt: (dest := dest - objectMemory wordSize) put: cogMethod asInteger].
+ source := source - objectMemory wordSize].
- objectMemory longAt: (dest := dest - BytesPerWord) put: cogMethod asInteger].
- source := source - BytesPerWord].
youngReferrers := dest.
"this assert must be deferred until after compaction. See the end of compactCogCompiledCode"
"self assert: self kosherYoungReferrers"!
Item was changed:
----- Method: CogMethodZone>>voidYoungReferrersPostTenureAll (in category 'jit - api') -----
voidYoungReferrersPostTenureAll
<var: #cogMethod type: #'CogMethod *'>
| pointer cogMethod |
<var: #pointer type: #usqInt>
<var: #cogMethod type: #'CogMethod *'>
self assert: youngReferrers <= limitAddress.
pointer := youngReferrers.
[pointer < limitAddress] whileTrue:
[cogMethod := coInterpreter cCoerceSimple: (objectMemory longAt: pointer) to: #'CogMethod *'.
cogMethod cmType ~= CMFree ifTrue:
[cogMethod cmRefersToYoung: false].
+ pointer := pointer + objectMemory wordSize].
- pointer := pointer + BytesPerWord].
youngReferrers := limitAddress!
Item was changed:
----- Method: CogObjectRepresentationFor32BitSpur>>genCreateClosureAt:numArgs:numCopied:contextNumArgs:large:inBlock: (in category 'bytecode generator support') -----
genCreateClosureAt: bcpc numArgs: numArgs numCopied: numCopied contextNumArgs: ctxtNumArgs large: isLargeCtxt inBlock: isInBlock
"Create a closure with the given startpc, numArgs and numCopied
within a context with ctxtNumArgs, large if isLargeCtxt that is in a
block if isInBlock. If numCopied > 0 pop those values off the stack."
self genNoPopCreateClosureAt: bcpc
numArgs: numArgs
numCopied: numCopied
contextNumArgs: ctxtNumArgs
large: isLargeCtxt
inBlock: isInBlock.
1 to: numCopied do:
[:i|
cogit
PopR: TempReg;
MoveR: TempReg
+ Mw: numCopied - i + ClosureFirstCopiedValueIndex * objectMemory bytesPerOop + objectMemory baseHeaderSize
- Mw: numCopied - i + ClosureFirstCopiedValueIndex * BytesPerOop + BaseHeaderSize
r: ReceiverResultReg].
^0!
Item was changed:
----- Method: CogObjectRepresentationFor32BitSpur>>genGetActiveContextLarge:inBlock: (in category 'initialization') -----
genGetActiveContextLarge: isLarge inBlock: isInBlock
"Create a trampoline to answer the active context that will
answer it if a frame is already married, and create it otherwise.
Assume numArgs is in SendNumArgsReg and ClassReg is free."
| header slotSize jumpSingle loopHead jumpNeedScavenge continuation exit |
<var: #jumpNeedScavenge type: #'AbstractInstruction *'>
<var: #continuation type: #'AbstractInstruction *'>
<var: #jumpSingle type: #'AbstractInstruction *'>
<var: #loopHead type: #'AbstractInstruction *'>
<var: #exit type: #'AbstractInstruction *'>
cogit
MoveMw: FoxMethod r: FPReg R: TempReg;
MoveR: TempReg R: ClassReg;
AndCq: MFMethodFlagHasContextFlag R: TempReg.
jumpSingle := cogit JumpZero: 0.
cogit
MoveMw: FoxThisContext r: FPReg R: ReceiverResultReg;
RetN: 0.
jumpSingle jmpTarget: cogit Label.
"OK, it doesn't exist; instantiate and initialize it"
"set the hasContext flag; See CoInterpreter class>>initializeFrameIndices"
cogit
OrCq: MFMethodFlagHasContextFlag R: ClassReg;
MoveR: ClassReg Mw: FoxMethod r: FPReg.
"now get the home CogMethod into ClassReg and save for post-instantiation."
isInBlock
ifTrue:
[cogit
SubCq: 3 R: ClassReg; "-3 is -(hasContext+isBlock) flags"
MoveM16: 0 r: ClassReg R: TempReg;
SubR: TempReg R: ClassReg]
ifFalse:
[cogit SubCq: 1 R: ClassReg]. "-1 is hasContext flag"
"instantiate the context..."
slotSize := isLarge ifTrue: [LargeContextSlots] ifFalse: [SmallContextSlots].
header := objectMemory
headerForSlots: slotSize
format: objectMemory indexablePointersFormat
classIndex: ClassMethodContextCompactIndex.
self flag: #endianness.
cogit
MoveAw: objectMemory freeStartAddress R: ReceiverResultReg;
MoveCq: (self cCoerceSimple: header to: #usqInt) R: TempReg;
MoveR: TempReg Mw: 0 r: ReceiverResultReg;
MoveCq: header >> 32 R: TempReg;
MoveR: TempReg Mw: 4 r: ReceiverResultReg;
MoveR: ReceiverResultReg R: TempReg;
AddCq: (objectMemory smallObjectBytesForSlots: slotSize) R: TempReg;
MoveR: TempReg Aw: objectMemory freeStartAddress;
CmpCq: objectMemory getScavengeThreshold R: TempReg.
jumpNeedScavenge := cogit JumpAboveOrEqual: 0.
"Now initialize the fields of the context. See CoInterpreter>>marryFrame:SP:copyTemps:"
"sender gets frame pointer as a SmallInteger"
continuation :=
cogit MoveR: FPReg R: TempReg.
self genSetSmallIntegerTagsIn: TempReg.
+ cogit MoveR: TempReg Mw: objectMemory baseHeaderSize + (SenderIndex * objectMemory bytesPerOop) r: ReceiverResultReg.
- cogit MoveR: TempReg Mw: BaseHeaderSize + (SenderIndex * BytesPerOop) r: ReceiverResultReg.
"pc gets frame caller as a SmallInteger"
cogit MoveMw: FoxSavedFP r: FPReg R: TempReg.
self genSetSmallIntegerTagsIn: TempReg.
+ cogit MoveR: TempReg Mw: objectMemory baseHeaderSize + (InstructionPointerIndex * objectMemory bytesPerOop) r: ReceiverResultReg.
- cogit MoveR: TempReg Mw: BaseHeaderSize + (InstructionPointerIndex * BytesPerOop) r: ReceiverResultReg.
"Set the method field, freeing up ClassReg again, and frame's context field,"
cogit
MoveMw: (cogit offset: CogMethod of: #methodObject) r: ClassReg R: TempReg;
+ MoveR: TempReg Mw: objectMemory baseHeaderSize + (MethodIndex * objectMemory wordSize) r: ReceiverResultReg;
- MoveR: TempReg Mw: BaseHeaderSize + (MethodIndex * BytesPerWord) r: ReceiverResultReg;
MoveR: ReceiverResultReg Mw: FoxThisContext r: FPReg.
"Now compute stack pointer; this is stackPointer (- 1 for return pc if a CISC) - framePointer - 4 (1 each for saved pc, method, context, receiver) + 1 (1-relative)"
cogit
MoveR: FPReg R: TempReg;
SubR: SPReg R: TempReg;
LogicalShiftRightCq: self log2BytesPerWord R: TempReg;
SubCq: (cogit backEnd hasLinkRegister ifTrue: [3] ifFalse: [4]) R: TempReg;
AddR: SendNumArgsReg R: TempReg.
self genConvertIntegerToSmallIntegerInReg: TempReg.
+ cogit MoveR: TempReg Mw: objectMemory baseHeaderSize + (StackPointerIndex * objectMemory bytesPerOop) r: ReceiverResultReg.
- cogit MoveR: TempReg Mw: BaseHeaderSize + (StackPointerIndex * BytesPerOop) r: ReceiverResultReg.
"Set closureOrNil to either the stacked receiver or nil"
isInBlock
ifTrue:
[cogit
MoveR: SendNumArgsReg R: TempReg;
AddCq: 2 R: TempReg; "+2 for saved fp and saved pc"
MoveXwr: TempReg R: FPReg R: TempReg]
ifFalse:
[cogit MoveCw: objectMemory nilObject R: TempReg].
+ cogit MoveR: TempReg Mw: objectMemory baseHeaderSize + (ClosureIndex * objectMemory bytesPerOop) r: ReceiverResultReg.
- cogit MoveR: TempReg Mw: BaseHeaderSize + (ClosureIndex * BytesPerOop) r: ReceiverResultReg.
"Set the receiver"
cogit
MoveMw: FoxMFReceiver r: FPReg R: TempReg;
+ MoveR: TempReg Mw: objectMemory baseHeaderSize + (ReceiverIndex * objectMemory bytesPerOop) r: ReceiverResultReg.
- MoveR: TempReg Mw: BaseHeaderSize + (ReceiverIndex * BytesPerOop) r: ReceiverResultReg.
"Now copy the arguments. This is tricky because of the shortage of registers,. ClassReg ranges
from 1 to numArgs (SendNumArgsReg), and from ReceiverIndex + 1 to ReceiverIndex + numArgs.
1 to: numArgs do:
[:i|
temp := longAt(FPReg + ((SendNumArgs - i + 2) * BytesPerWord)). +2 for saved pc and savedfp
longAtput(FPReg + FoxMFReceiver + (i * BytesPerWord), temp)]"
cogit MoveCq: 1 R: ClassReg.
loopHead := cogit CmpR: SendNumArgsReg R: ClassReg.
exit := cogit JumpGreater: 0.
cogit
MoveR: SendNumArgsReg R: TempReg;
SubR: ClassReg R: TempReg;
AddCq: 2 R: TempReg; "+2 for saved fp and saved pc"
MoveXwr: TempReg R: FPReg R: TempReg;
+ AddCq: ReceiverIndex + (objectMemory baseHeaderSize / objectMemory wordSize) R: ClassReg; "Now convert ClassReg from frame index to context index"
- AddCq: ReceiverIndex + (BaseHeaderSize / BytesPerWord) R: ClassReg; "Now convert ClassReg from frame index to context index"
MoveR: TempReg Xwr: ClassReg R: ReceiverResultReg;
+ SubCq: ReceiverIndex + (objectMemory baseHeaderSize / objectMemory wordSize) - 1 R: ClassReg; "convert back adding 1 ;-)"
- SubCq: ReceiverIndex + (BaseHeaderSize / BytesPerWord) - 1 R: ClassReg; "convert back adding 1 ;-)"
Jump: loopHead.
exit jmpTarget: cogit Label.
"Finally copy the temps.
ClassReg := FPReg + FoxMFReceiver.
SendNumArgsReg := SendNumArgsReg+ReceiverIndex.
[ClassReg := ClassReg - 4.
backEnd hasLinkRegister
ifTrue: [ClassReg > SPReg]
ifFalse: [ClassReg >= SPReg]] whileTrue:
[receiver[SendNumArgsReg] := *ClassReg.
SendNumArgsReg := SendNumArgsReg + 1]]"
cogit
MoveR: FPReg R: ClassReg;
AddCq: FoxMFReceiver R: ClassReg;
+ AddCq: ReceiverIndex + 1 + (objectMemory baseHeaderSize / objectMemory wordSize) R: SendNumArgsReg.
- AddCq: ReceiverIndex + 1 + (BaseHeaderSize / BytesPerWord) R: SendNumArgsReg.
loopHead :=
+ cogit SubCq: objectMemory wordSize R: ClassReg.
- cogit SubCq: BytesPerWord R: ClassReg.
cogit CmpR: SPReg R: ClassReg.
exit := cogit backEnd hasLinkRegister
ifTrue: [cogit JumpBelowOrEqual: 0]
ifFalse: [cogit JumpBelow: 0].
cogit
MoveMw: 0 r: ClassReg R: TempReg;
MoveR: TempReg Xwr: SendNumArgsReg R: ReceiverResultReg;
AddCq: 1 R: SendNumArgsReg;
Jump: loopHead.
exit jmpTarget: cogit Label.
cogit RetN: 0.
jumpNeedScavenge jmpTarget:
(cogit CallRT: ceSheduleScavengeTrampoline).
cogit Jump: continuation.
^0!
Item was changed:
----- Method: CogObjectRepresentationFor32BitSpur>>genGetInlineCacheClassTagFrom:into:forEntry: (in category 'compile abstract instructions') -----
genGetInlineCacheClassTagFrom: sourceReg into: destReg forEntry: forEntry
"Extract the inline cache tag for the object in sourceReg into destReg. The inline
cache tag for a given object is the value loaded in inline caches to distinguish
objects of different classes. In Spur this is either the tags for immediates, (with
1 & 3 collapsed to 1 for SmallIntegers, and 2 collapsed to 0 for Characters), or
the receiver's classIndex.
If forEntry is true answer the entry label at which control is to enter (cmEntryOffset).
If forEntry is false, control enters at the start.
If forEntry is false, generate something like this:
Limm:
andl $0x1, rDest
j Lcmp
Lentry:
movl rSource, rDest
andl $0x3, rDest
jnz Limm
movl 0(%edx), rDest
andl $0x3fffff, rDest
Lcmp:
If forEntry is true, generate something like the following.
At least on a 2.2GHz Intel Core i7 the following is slightly faster than the above,
136m sends/sec vs 130m sends/sec for nfib in tinyBenchmarks
Lentry:
movl rSource, rDest
andl $0x3, rDest
jz LnotImm
andl $1, rDest
j Lcmp
LnotImm:
movl 0(%edx), rDest
andl $0x3fffff, rDest
Lcmp:
But we expect most SmallInteger arithmetic to be performed in-line and so prefer the
version that is faster for non-immediates (because it branches for immediates only)."
| immLabel jumpNotImm entryLabel jumpCompare |
<var: #immLabel type: #'AbstractInstruction *'>
<var: #jumpNotImm type: #'AbstractInstruction *'>
<var: #entryLabel type: #'AbstractInstruction *'>
<var: #jumpCompare type: #'AbstractInstruction *'>
forEntry
ifFalse:
[entryLabel := cogit Label.
cogit MoveR: sourceReg R: destReg.
cogit AndCq: objectMemory tagMask R: destReg.
jumpNotImm := cogit JumpZero: 0.
cogit AndCq: 1 R: destReg.
jumpCompare := cogit Jump: 0.
"Get least significant half of header word in destReg"
self flag: #endianness.
jumpNotImm jmpTarget:
(cogit MoveMw: 0 r: sourceReg R: destReg).
jumpCompare jmpTarget:
(cogit AndCq: objectMemory classIndexMask R: destReg)]
ifTrue:
+ [cogit AlignmentNops: objectMemory wordSize.
- [cogit AlignmentNops: BytesPerWord.
immLabel := cogit Label.
cogit AndCq: 1 R: destReg.
jumpCompare := cogit Jump: 0.
+ cogit AlignmentNops: objectMemory wordSize.
- cogit AlignmentNops: BytesPerWord.
entryLabel := cogit Label.
cogit MoveR: sourceReg R: destReg.
cogit AndCq: objectMemory tagMask R: destReg.
cogit JumpNonZero: immLabel.
self flag: #endianness.
"Get least significant half of header word in destReg"
cogit MoveMw: 0 r: sourceReg R: destReg.
cogit AndCq: objectMemory classIndexMask R: destReg.
jumpCompare jmpTarget: cogit Label].
^entryLabel!
Item was changed:
----- Method: CogObjectRepresentationFor32BitSpur>>genNoPopCreateClosureAt:numArgs:numCopied:contextNumArgs:large:inBlock: (in category 'bytecode generator support') -----
genNoPopCreateClosureAt: bcpc numArgs: numArgs numCopied: numCopied contextNumArgs: ctxtNumArgs large: isLargeCtxt inBlock: isInBlock
"Create a closure with the given startpc, numArgs and numCopied
within a context with ctxtNumArgs, large if isLargeCtxt that is in a
block if isInBlock. Do /not/ initialize the copied values."
| slotSize header skip |
<var: #skip type: #'AbstractInstruction *'>
"First get thisContext into ReceiverResultRega and thence in ClassReg."
self genGetActiveContextNumArgs: ctxtNumArgs large: isLargeCtxt inBlock: isInBlock.
cogit MoveR: ReceiverResultReg R: ClassReg.
slotSize := ClosureFirstCopiedValueIndex + numCopied.
header := objectMemory
headerForSlots: slotSize
format: objectMemory indexablePointersFormat
classIndex: ClassBlockClosureCompactIndex.
cogit
MoveAw: objectMemory freeStartAddress R: ReceiverResultReg;
MoveCq: (self cCoerceSimple: header to: #usqInt) R: TempReg;
MoveR: TempReg Mw: 0 r: ReceiverResultReg;
MoveCq: header >> 32 R: TempReg;
MoveR: TempReg Mw: 4 r: ReceiverResultReg;
MoveR: ReceiverResultReg R: TempReg;
AddCq: (objectMemory smallObjectBytesForSlots: slotSize) R: TempReg;
MoveR: TempReg Aw: objectMemory freeStartAddress;
CmpCq: objectMemory getScavengeThreshold R: TempReg.
skip := cogit JumpBelow: 0.
cogit CallRT: ceSheduleScavengeTrampoline.
skip jmpTarget: cogit Label.
cogit
+ MoveR: ClassReg Mw: ClosureOuterContextIndex * objectMemory bytesPerOop + objectMemory baseHeaderSize r: ReceiverResultReg;
- MoveR: ClassReg Mw: ClosureOuterContextIndex * BytesPerOop + BaseHeaderSize r: ReceiverResultReg;
MoveCq: (objectMemory integerObjectOf: bcpc) R: TempReg;
+ MoveR: TempReg Mw: ClosureStartPCIndex * objectMemory bytesPerOop + objectMemory baseHeaderSize r: ReceiverResultReg;
- MoveR: TempReg Mw: ClosureStartPCIndex * BytesPerOop + BaseHeaderSize r: ReceiverResultReg;
MoveCq: (objectMemory integerObjectOf: numArgs) R: TempReg;
+ MoveR: TempReg Mw: ClosureNumArgsIndex * objectMemory bytesPerOop + objectMemory baseHeaderSize r: ReceiverResultReg.
- MoveR: TempReg Mw: ClosureNumArgsIndex * BytesPerOop + BaseHeaderSize r: ReceiverResultReg.
^0!
Item was changed:
----- Method: CogObjectRepresentationForSqueakV3>>checkValidInlineCacheTag: (in category 'garbage collection') -----
checkValidInlineCacheTag: cacheTag
^cacheTag = ConstZero
+ or: [((cacheTag bitAnd: 1 << objectMemory shiftForWord - 1) = 0
- or: [((cacheTag bitAnd: 1 << ShiftForWord - 1) = 0
and: [cacheTag
between: 1 << objectMemory compactClassFieldLSB
and: (objectMemory compactClassIndexOfHeader: -1) << objectMemory compactClassFieldLSB])
or: [self checkValidObjectReference: cacheTag]]!
Item was changed:
----- Method: CogObjectRepresentationForSqueakV3>>genAllocFloatValue:into:scratchReg:scratchReg: (in category 'compile abstract instructions') -----
genAllocFloatValue: dpreg into: resultReg scratchReg: scratch1 scratchReg: scratch2
<returnTypeC: #'AbstractInstruction *'>
| allocSize newFloatHeaderSansHash jumpFail |
<var: #jumpFail type: #'AbstractInstruction *'>
+ allocSize := objectMemory baseHeaderSize + (objectMemory sizeof: #double).
- allocSize := BaseHeaderSize + (objectMemory sizeof: #double).
newFloatHeaderSansHash := ((ClassFloatCompactIndex << objectMemory compactClassFieldLSB
bitOr: (objectMemory formatOfClass: objectMemory classFloat))
bitOr: allocSize)
bitOr: HeaderTypeShort.
cogit MoveAw: objectMemory freeStartAddress R: resultReg.
cogit MoveR: resultReg R: scratch1.
cogit AddCq: allocSize R: scratch1.
cogit MoveAw: objectMemory scavengeThresholdAddress R: scratch2.
cogit CmpR: scratch2 R: scratch1.
jumpFail := cogit JumpAboveOrEqual: 0.
cogit MoveR: resultReg R: scratch2.
self flag: #newObjectHash.
+ cogit AndCq: HashMaskUnshifted << objectMemory wordSize R: scratch2.
+ cogit LogicalShiftLeftCq: HashBitsOffset - objectMemory wordSize R: scratch2.
- cogit AndCq: HashMaskUnshifted << BytesPerWord R: scratch2.
- cogit LogicalShiftLeftCq: HashBitsOffset - BytesPerWord R: scratch2.
cogit OrCq: newFloatHeaderSansHash R: scratch2.
cogit MoveR: scratch2 Mw: 0 r: resultReg.
+ cogit MoveRd: dpreg M64: objectMemory baseHeaderSize r: resultReg.
- cogit MoveRd: dpreg M64: BaseHeaderSize r: resultReg.
cogit MoveR: scratch1 Aw: objectMemory freeStartAddress.
^jumpFail!
Item was changed:
----- Method: CogObjectRepresentationForSqueakV3>>genCreateClosureAt:numArgs:numCopied:contextNumArgs:large:inBlock: (in category 'bytecode generator support') -----
genCreateClosureAt: bcpc numArgs: numArgs numCopied: numCopied contextNumArgs: ctxtNumArgs large: isLargeCtxt inBlock: isInBlock
"Create a closure with the given startpc, numArgs and numCopied
within a context with ctxtNumArgs, large if isLargeCtxt that is in a
block if isInBlock. If numCopied > 0 pop those values off the stack."
"see ceClosureCopyDescriptor:"
cogit MoveCq: numArgs + (numCopied << 6) + (bcpc << 12) R: SendNumArgsReg.
cogit CallRT: ceClosureCopyTrampoline.
numCopied > 0 ifTrue:
+ [cogit AddCq: numCopied * objectMemory wordSize R: SPReg].
- [cogit AddCq: numCopied * BytesPerWord R: SPReg].
^0!
Item was changed:
----- Method: CogObjectRepresentationForSqueakV3>>genGetClassFormatOfNonInt:into:scratchReg: (in category 'compile abstract instructions') -----
genGetClassFormatOfNonInt: instReg into: destReg scratchReg: scratchReg
"Fetch the instance's class format into destReg, assuming the object is non-int."
| jumpCompact jumpGotClass |
<var: #jumpCompact type: #'AbstractInstruction *'>
<var: #jumpGotClass type: #'AbstractInstruction *'>
"Get header word in destReg"
cogit MoveMw: 0 r: instReg R: destReg.
"Form the byte index of the compact class field"
+ cogit LogicalShiftRightCq: (objectMemory compactClassFieldLSB - objectMemory shiftForWord) R: destReg.
+ cogit AndCq: self compactClassFieldMask << objectMemory shiftForWord R: destReg.
- cogit LogicalShiftRightCq: (objectMemory compactClassFieldLSB - ShiftForWord) R: destReg.
- cogit AndCq: self compactClassFieldMask << ShiftForWord R: destReg.
jumpCompact := cogit JumpNonZero: 0.
cogit MoveMw: objectMemory classFieldOffset r: instReg R: scratchReg.
"The use of signedIntFromLong is a hack to get round short addressing mode computations.
Much easier if offsets are signed and the arithmetic machinery we have makes it difficult to
mix signed and unsigned offsets."
cogit AndCq: AllButTypeMask signedIntFromLong R: scratchReg.
jumpGotClass := cogit Jump: 0.
"Don't have to subtract one from the destReg compactClassArray index because of the header word."
+ self assert: objectMemory baseHeaderSize = objectMemory wordSize.
- self assert: BaseHeaderSize = BytesPerWord.
jumpCompact jmpTarget:
(cogit annotate: (cogit MoveMw: (objectMemory splObj: CompactClasses) r: destReg R: scratchReg)
objRef: (objectMemory splObj: CompactClasses)).
jumpGotClass jmpTarget:
+ (cogit MoveMw: InstanceSpecificationIndex << objectMemory shiftForWord + objectMemory wordSize r: scratchReg R: destReg).
- (cogit MoveMw: InstanceSpecificationIndex << ShiftForWord + BytesPerWord r: scratchReg R: destReg).
^0!
Item was changed:
----- Method: CogObjectRepresentationForSqueakV3>>genGetClassObjectOf:into:scratchReg:instRegIsReceiver: (in category 'compile abstract instructions') -----
genGetClassObjectOf: instReg into: destReg scratchReg: scratchReg instRegIsReceiver: instRegIsReceiver
"Fetch the instance's class into destReg. This is almost identical
to genGetClassFormatOfNonInt:into:scratchReg: but because we
put the fetch of SmallInteger between the then and the else for
compact class/non-compact class we cannot easily share code.
instRegIsReceiver is ignored. It is for Spur compatibility where
objects may be forwarded."
| jumpIsInt jumpCompact jumpGotClass jumpGotClass2 |
<var: #jumpIsInt type: #'AbstractInstruction *'>
<var: #jumpCompact type: #'AbstractInstruction *'>
<var: #jumpGotClass type: #'AbstractInstruction *'>
<var: #jumpGotClass2 type: #'AbstractInstruction *'>
cogit MoveR: instReg R: scratchReg.
cogit AndCq: 1 R: scratchReg.
jumpIsInt := cogit JumpNonZero: 0.
"Get header word in scratchReg"
cogit MoveMw: 0 r: instReg R: scratchReg.
"Form the byte index of the compact class field"
+ cogit LogicalShiftRightCq: (objectMemory compactClassFieldLSB - objectMemory shiftForWord) R: scratchReg.
+ cogit AndCq: self compactClassFieldMask << objectMemory shiftForWord R: scratchReg.
- cogit LogicalShiftRightCq: (objectMemory compactClassFieldLSB - ShiftForWord) R: scratchReg.
- cogit AndCq: self compactClassFieldMask << ShiftForWord R: scratchReg.
jumpCompact := cogit JumpNonZero: 0.
cogit MoveMw: objectMemory classFieldOffset r: instReg R: destReg.
cogit AndCq: AllButTypeMask signedIntFromLong R: destReg.
jumpGotClass := cogit Jump: 0.
jumpIsInt jmpTarget:
(cogit annotate: (cogit MoveCw: objectMemory classSmallInteger R: destReg)
objRef: objectMemory classSmallInteger).
jumpGotClass2 := cogit Jump: 0.
"Don't have to subtract one from the destReg compactClassArray index because of the header word."
+ self assert: objectMemory baseHeaderSize = objectMemory wordSize.
- self assert: BaseHeaderSize = BytesPerWord.
jumpCompact jmpTarget:
(cogit annotate: (cogit MoveMw: (objectMemory splObj: CompactClasses) r: scratchReg R: destReg)
objRef: (objectMemory splObj: CompactClasses)).
jumpGotClass jmpTarget:
(jumpGotClass2 jmpTarget: cogit Label).
^0!
Item was changed:
----- Method: CogObjectRepresentationForSqueakV3>>genGetClassTagOf:into:scratchReg: (in category 'compile abstract instructions') -----
genGetClassTagOf: instReg into: destReg scratchReg: scratchReg
"Compatibility with SpurObjectRepresentation/SpurMemoryManager."
| entryLabel |
<var: #entryLabel type: #'AbstractInstruction *'>
+ cogit AlignmentNops: (objectMemory wordSize max: 8).
- cogit AlignmentNops: (BytesPerWord max: 8).
entryLabel := cogit Label.
self genGetClassObjectOf: instReg into: destReg scratchReg: scratchReg instRegIsReceiver: nil.
^entryLabel!
Item was changed:
----- Method: CogObjectRepresentationForSqueakV3>>genGetDoubleValueOf:into: (in category 'compile abstract instructions') -----
genGetDoubleValueOf: srcReg into: destFPReg
+ cogit MoveM64: objectMemory baseHeaderSize r: srcReg Rd: destFPReg.
- cogit MoveM64: BaseHeaderSize r: srcReg Rd: destFPReg.
^0!
Item was changed:
----- Method: CogObjectRepresentationForSqueakV3>>genGetInlineCacheClassTagFrom:into:forEntry: (in category 'compile abstract instructions') -----
genGetInlineCacheClassTagFrom: sourceReg into: destReg forEntry: forEntry
"Extract the inline cache tag for the object in sourceReg into destReg. The inline cache tag
for a given object is the value loaded in inline caches to distinguish objects of different
classes. In Spur this is either the tags for immediates, or the receiver's classIndex.
The inline cache tag for a given object is the value loaded in inline caches to distinguish
objects of different classes. In SqueakV3 the tag is the integer tag bit for SmallIntegers (1),
the compact class index shifted by log: 2 word size for objects with compact classes
(1 * 4 to: 31 * 4 by: 4), or the class. These ranges cannot overlap because the heap
(and hence the lowest class object) is beyond the machine code zone.
If forEntry is true answer the entry label at which control is to enter (cmEntryOffset).
If forEntry is false, control enters at the start."
| entryLabel jumpIsInt jumpCompact |
<var: #entryLabel type: #'AbstractInstruction *'>
<var: #jumpIsInt type: #'AbstractInstruction *'>
<var: #jumpCompact type: #'AbstractInstruction *'>
+ cogit AlignmentNops: (objectMemory wordSize max: 8).
- cogit AlignmentNops: (BytesPerWord max: 8).
entryLabel := cogit Label.
cogit MoveR: sourceReg R: destReg.
cogit AndCq: 1 R: destReg.
jumpIsInt := cogit JumpNonZero: 0.
"Get header word in destReg"
cogit MoveMw: 0 r: sourceReg R: destReg.
"Extract the compact class field, and if non-zero use it as the tag.."
self assert: self compactClassFieldMask << objectMemory compactClassFieldLSB < objectMemory nilObject asUnsignedInteger.
cogit AndCq: self compactClassFieldMask << objectMemory compactClassFieldLSB R: destReg.
jumpCompact := cogit JumpNonZero: 0.
cogit MoveMw: objectMemory classFieldOffset r: sourceReg R: destReg.
"The use of signedIntFromLong is a hack to get round short addressing mode computations.
Much easier if offsets are signed and the arithmetic machinery we have makes it difficult to
mix signed and unsigned offsets."
cogit AndCq: AllButTypeMask signedIntFromLong R: destReg.
jumpCompact jmpTarget: (jumpIsInt jmpTarget: cogit Label).
^entryLabel!
Item was changed:
----- Method: CogObjectRepresentationForSqueakV3>>genGetSizeOf:into:formatReg:scratchReg:abortJumpsInto: (in category 'primitive generators') -----
genGetSizeOf: sourceReg into: destReg formatReg: formatReg scratchReg: scratchReg abortJumpsInto: aBinaryBlock
"Get the size of the non-immediate object in sourceReg into destReg using formatReg
and scratchReg as temps. None of these registers can overlap. Supply the jumps
taken if the object in sourceReg is not indexable, or if the object in sourceReg is a
context.. Hack: If the object has a pointer format other than 2 leave the number of
fixed fields in formatReg. Used by primitiveSize, primitiveAt, and primitiveAtPut"
<returnTypeC: #'AbstractInstruction *'>
| jumpNotIndexable jumpIsContext jumpShortHeader jumpSkip
jumpFmtLeWeakArray jumpFmtIsArray jmpFmtGeFirstByte jumpGotByteSize jumpGotWordSize |
<inline: true>
"c.f. StackInterpreter>>stSizeOf: lengthOf:baseHeader:format: fixedFieldsOf:format:length:"
"and one wonders why Squeak V1 through V3 are slow..."
<var: #jumpNotIndexable type: #'AbstractInstruction *'>
<var: #jumpIsContext type: #'AbstractInstruction *'>
<var: #jumpShortHeader type: #'AbstractInstruction *'>
<var: #jumpSkip type: #'AbstractInstruction *'>
<var: #jumpFmtLeWeakArray type: #'AbstractInstruction *'>
<var: #jumpFmtIsArray type: #'AbstractInstruction *'>
<var: #jmpFmtGeFirstByte type: #'AbstractInstruction *'>
<var: #jumpGotByteSize type: #'AbstractInstruction *'>
<var: #jumpGotWordSize type: #'AbstractInstruction *'>
cogit
MoveMw: 0 r: sourceReg R: formatReg; "destReg := self baseHeader: receiver"
MoveR: formatReg R: destReg;
LogicalShiftRightCq: objectMemory instFormatFieldLSB R: formatReg;
AndCq: self instFormatFieldMask R: formatReg; "formatReg := self formatOfHeader: destReg"
CmpCq: objectMemory arrayFormat R: formatReg.
jumpNotIndexable := cogit JumpLess: 0.
cogit
MoveR: destReg R: scratchReg;
LogicalShiftRightCq: objectMemory compactClassFieldLSB R: scratchReg;
AndCq: self compactClassFieldMask R: scratchReg; "scratchReg := self compactClassIndexOfHeader: destReg"
CmpCq: ClassMethodContextCompactIndex R: scratchReg.
jumpIsContext := cogit JumpZero: 0.
cogit
MoveR: destReg R: scratchReg;
AndCq: TypeMask R: scratchReg;
CmpCq: HeaderTypeSizeAndClass R: scratchReg. "(hdr bitAnd: TypeMask) = HeaderTypeSizeAndClass"
jumpShortHeader := cogit JumpNonZero: 0.
self assert: Size4Bit = 0.
cogit
+ MoveMw: 0 - (2 * objectMemory wordSize) r: sourceReg R: destReg; "(self sizeHeader: oop) bitAnd: LongSizeMask"
- MoveMw: 0 - (2 * BytesPerWord) r: sourceReg R: destReg; "(self sizeHeader: oop) bitAnd: LongSizeMask"
AndCq: LongSizeMask signedIntFromLong R: destReg.
jumpSkip := cogit Jump: 0.
jumpShortHeader jmpTarget: (cogit AndCq: SizeMask R: destReg). "hdr bitAnd: SizeMask"
+ jumpSkip jmpTarget: (cogit SubCq: objectMemory baseHeaderSize R: destReg). "sz - BaseheaderSize for all three arms"
- jumpSkip jmpTarget: (cogit SubCq: BaseHeaderSize R: destReg). "sz - BaseheaderSize for all three arms"
cogit CmpCq: objectMemory weakArrayFormat R: formatReg. "fmt <= 4"
jumpFmtLeWeakArray := cogit JumpLessOrEqual: 0.
cogit CmpCq: objectMemory firstByteFormat R: formatReg.
jmpFmtGeFirstByte := cogit JumpLess: 0.
cogit
AndCq: 3 R: formatReg; "(sz - BaseHeaderSize) - (fmt bitAnd: 3) bytes"
SubR: formatReg R: destReg.
jumpGotByteSize := cogit Jump: 0.
jmpFmtGeFirstByte jmpTarget: (cogit LogicalShiftRightCq: 2 R: destReg). "(sz - BaseHeaderSize) >> 2 32-bit longs"
jumpGotWordSize := cogit Jump: 0.
jumpFmtLeWeakArray jmpTarget: cogit Label.
cogit
+ LogicalShiftRightCq: objectMemory shiftForWord R: destReg; "(sz - BaseHeaderSize) >> ShiftForWord words"
- LogicalShiftRightCq: ShiftForWord R: destReg; "(sz - BaseHeaderSize) >> ShiftForWord words"
CmpCq: objectMemory arrayFormat R: formatReg.
jumpFmtIsArray := cogit JumpZero: 0.
self genGetFixedFieldsOfPointerNonInt: sourceReg into: formatReg scratchReg: scratchReg.
cogit SubR: formatReg R: destReg.
jumpFmtIsArray jmpTarget:
(jumpGotWordSize jmpTarget:
(jumpGotByteSize jmpTarget:
cogit Label)).
aBinaryBlock value: jumpNotIndexable value: jumpIsContext!
Item was changed:
----- Method: CogObjectRepresentationForSqueakV3>>genInnerPrimitiveAt: (in category 'primitive generators') -----
genInnerPrimitiveAt: retNoffset
| jumpSI jumpNotSI jumpNotIndexable jumpIsContext jumpBounds jumpFmtGt4 jumpFmtEq2 jumpFmtLt8 jumpFmtGt11 jumpLarge |
"c.f. StackInterpreter>>stSizeOf: lengthOf:baseHeader:format: fixedFieldsOf:format:length:"
<var: #jumpSI type: #'AbstractInstruction *'>
<var: #jumpNotSI type: #'AbstractInstruction *'>
<var: #jumpNotIndexable type: #'AbstractInstruction *'>
<var: #jumpIsContext type: #'AbstractInstruction *'>
<var: #jumpBounds type: #'AbstractInstruction *'>
<var: #jumpFmtGt4 type: #'AbstractInstruction *'>
<var: #jumpFmtEq2 type: #'AbstractInstruction *'>
<var: #jumpFmtLt8 type: #'AbstractInstruction *'>
<var: #jumpFmtGt11 type: #'AbstractInstruction *'>
<var: #jumpLarge type: #'AbstractInstruction *'>
cogit MoveR: ReceiverResultReg R: TempReg.
jumpSI := self genJumpSmallIntegerInScratchReg: TempReg.
cogit MoveR: Arg0Reg R: TempReg.
cogit MoveR: Arg0Reg R: Arg1Reg.
jumpNotSI := self genJumpNotSmallIntegerInScratchReg: TempReg.
self
genGetSizeOf: ReceiverResultReg
into: ClassReg
formatReg: SendNumArgsReg
scratchReg: TempReg
abortJumpsInto: [:jnx :jic| jumpNotIndexable := jnx. jumpIsContext := jic].
self genConvertSmallIntegerToIntegerInReg: Arg1Reg.
cogit SubCq: 1 R: Arg1Reg.
cogit CmpR: ClassReg R: Arg1Reg.
jumpBounds := cogit JumpAboveOrEqual: 0.
"This is tedious. Because of register pressure on x86 (and the baroque
complexity of the size computation) we have to recompute the format
because it may have been smashed computing the fixed fields. But at
least we have the fixed fields, if any, in formatReg and recomputing
these is more expensive than recomputing format. In any case this
should still be faster than the interpreter and we hope this object
representation's days are numbered."
cogit
MoveMw: 0 r: ReceiverResultReg R: ClassReg; "self baseHeader: receiver"
LogicalShiftRightCq: objectMemory instFormatFieldLSB R: ClassReg;
AndCq: self instFormatFieldMask R: ClassReg; "self formatOfHeader: ClassReg"
CmpCq: 4 R: ClassReg.
jumpFmtGt4 := cogit JumpGreater: 0.
cogit CmpCq: 2 R: ClassReg. "Common case, e.g. Array, has format = 2"
jumpFmtEq2 := cogit JumpZero: 0.
cogit AddR: SendNumArgsReg R: Arg1Reg. "Add fixed fields to index"
jumpFmtEq2 jmpTarget: cogit Label.
cogit "Too lazy [knackered, more like. ed.] to define index with displacement addressing right now"
+ AddCq: objectMemory baseHeaderSize / objectMemory wordSize R: Arg1Reg;
- AddCq: BaseHeaderSize / BytesPerWord R: Arg1Reg;
MoveXwr: Arg1Reg R: ReceiverResultReg R: ReceiverResultReg;
RetN: retNoffset.
jumpFmtGt4 jmpTarget: cogit Label.
"Byte objects have formats 8 through 15, Compiled methods being 12 through 15;
fail for CompiledMethod allowing the CoInterpeter to impose stricter bounds checks."
cogit CmpCq: 8 R: ClassReg.
jumpFmtLt8 := cogit JumpLess: 0.
cogit CmpCq: 11 R: ClassReg.
jumpFmtGt11 := cogit JumpGreater: 0.
cogit
+ AddCq: objectMemory baseHeaderSize R: Arg1Reg;
- AddCq: BaseHeaderSize R: Arg1Reg;
MoveXbr: Arg1Reg R: ReceiverResultReg R: ReceiverResultReg.
self genConvertIntegerToSmallIntegerInReg: ReceiverResultReg.
cogit RetN: retNoffset.
jumpFmtLt8 jmpTarget: cogit Label.
+ self assert: objectMemory wordSize = 4. "documenting my laziness"
- self assert: BytesPerWord = 4. "documenting my laziness"
cogit "Too lazy [knackered, more like. ed.] to define index with displacement addressing right now"
+ AddCq: objectMemory baseHeaderSize / objectMemory wordSize R: Arg1Reg;
- AddCq: BaseHeaderSize / BytesPerWord R: Arg1Reg;
MoveXwr: Arg1Reg R: ReceiverResultReg R: ReceiverResultReg;
CmpCq: 16r3FFFFFFF R: ReceiverResultReg.
jumpLarge := cogit JumpAbove: 0.
self genConvertIntegerToSmallIntegerInScratchReg: ReceiverResultReg.
cogit RetN: retNoffset.
jumpLarge jmpTarget: (cogit CallRT: cePositive32BitIntegerTrampoline).
cogit
MoveR: TempReg R: ReceiverResultReg;
RetN: retNoffset.
jumpSI jmpTarget:
(jumpNotSI jmpTarget:
(jumpNotIndexable jmpTarget:
(jumpIsContext jmpTarget:
(jumpBounds jmpTarget:
(jumpFmtGt11 jmpTarget:
cogit Label))))).
^0!
Item was changed:
----- Method: CogObjectRepresentationForSqueakV3>>genInnerPrimitiveStringAt: (in category 'primitive generators') -----
genInnerPrimitiveStringAt: retNOffset
| jumpSI jumpNotSI jumpNotByteIndexable jumpBounds jumpShortHeader jumpSkip |
"c.f. StackInterpreter>>stSizeOf: lengthOf:baseHeader:format: fixedFieldsOf:format:length:"
<var: #jumpSI type: #'AbstractInstruction *'>
<var: #jumpNotSI type: #'AbstractInstruction *'>
<var: #jumpNotByteIndexable type: #'AbstractInstruction *'>
<var: #jumpBounds type: #'AbstractInstruction *'>
<var: #jumpShortHeader type: #'AbstractInstruction *'>
<var: #jumpSkip type: #'AbstractInstruction *'>
cogit MoveR: ReceiverResultReg R: TempReg.
jumpSI := self genJumpSmallIntegerInScratchReg: TempReg.
cogit MoveR: Arg0Reg R: TempReg.
cogit MoveR: Arg0Reg R: Arg1Reg.
jumpNotSI := self genJumpNotSmallIntegerInScratchReg: TempReg.
cogit
MoveMw: 0 r: ReceiverResultReg R: TempReg; "self baseHeader: receiver"
MoveR: TempReg R: ClassReg; "copy header word; we'll need it later"
LogicalShiftRightCq: objectMemory instFormatFieldLSB R: TempReg;
AndCq: self instFormatFieldMask R: TempReg; "self formatOfHeader: destReg"
MoveR: TempReg R: SendNumArgsReg;
AndCq: 3 R: SendNumArgsReg; "get odd bytes from format (if it turns out to be bytes)"
SubR: SendNumArgsReg R: TempReg;
CmpCq: 8 R: TempReg. "check format is 8"
jumpNotByteIndexable := cogit JumpNonZero: 0.
cogit
MoveR: ClassReg R: TempReg;
AndCq: TypeMask R: TempReg;
CmpCq: HeaderTypeSizeAndClass R: TempReg. "(hdr bitAnd: TypeMask) = HeaderTypeSizeAndClass"
jumpShortHeader := cogit JumpNonZero: 0.
self assert: Size4Bit = 0.
cogit
+ MoveMw: 0 - (2 * objectMemory wordSize) r: ReceiverResultReg R: ClassReg; "(self sizeHeader: oop) bitAnd: LongSizeMask"
- MoveMw: 0 - (2 * BytesPerWord) r: ReceiverResultReg R: ClassReg; "(self sizeHeader: oop) bitAnd: LongSizeMask"
AndCq: LongSizeMask signedIntFromLong R: ClassReg.
jumpSkip := cogit Jump: 0.
jumpShortHeader jmpTarget: (cogit AndCq: SizeMask R: ClassReg). "hdr bitAnd: SizeMask"
+ jumpSkip jmpTarget: (cogit SubCq: objectMemory baseHeaderSize R: ClassReg). "sz - BaseHeaderSize"
- jumpSkip jmpTarget: (cogit SubCq: BaseHeaderSize R: ClassReg). "sz - BaseHeaderSize"
cogit SubR: SendNumArgsReg R: ClassReg. "sz - (fmt bitAnd: 3)"
self genConvertSmallIntegerToIntegerInReg: Arg1Reg.
cogit SubCq: 1 R: Arg1Reg.
cogit CmpR: ClassReg R: Arg1Reg.
jumpBounds := cogit JumpAboveOrEqual: 0.
+ cogit AddCq: objectMemory baseHeaderSize R: Arg1Reg.
- cogit AddCq: BaseHeaderSize R: Arg1Reg.
cogit annotate: (cogit MoveCw: objectMemory characterTable R: Arg0Reg)
objRef: objectMemory characterTable.
cogit MoveXbr: Arg1Reg R: ReceiverResultReg R: ReceiverResultReg;
+ AddCq: objectMemory baseHeaderSize / objectMemory wordSize R: ReceiverResultReg.
- AddCq: BaseHeaderSize / BytesPerWord R: ReceiverResultReg.
cogit MoveXwr: ReceiverResultReg R: Arg0Reg R: ReceiverResultReg.
cogit RetN: retNOffset.
jumpSI jmpTarget:
(jumpNotSI jmpTarget:
(jumpNotByteIndexable jmpTarget:
(jumpBounds jmpTarget:
cogit Label))).
^0!
Item was changed:
----- Method: CogObjectRepresentationForSqueakV3>>genLoadSlot:sourceReg:destReg: (in category 'compile abstract instructions') -----
genLoadSlot: index sourceReg: sourceReg destReg: destReg
+ cogit MoveMw: index * objectMemory wordSize + objectMemory baseHeaderSize r: sourceReg R: destReg.
- cogit MoveMw: index * BytesPerWord + BaseHeaderSize r: sourceReg R: destReg.
^0!
Item was changed:
----- Method: CogObjectRepresentationForSqueakV3>>genStoreImmediateInSourceReg:slotIndex:destReg: (in category 'compile abstract instructions') -----
genStoreImmediateInSourceReg: sourceReg slotIndex: index destReg: destReg
+ cogit MoveR: sourceReg Mw: index * objectMemory wordSize + objectMemory baseHeaderSize r: destReg.
- cogit MoveR: sourceReg Mw: index * BytesPerWord + BaseHeaderSize r: destReg.
^0!
Item was changed:
----- Method: CogObjectRepresentationForSqueakV3>>genStoreSourceReg:slotIndex:destReg:scratchReg: (in category 'compile abstract instructions') -----
genStoreSourceReg: sourceReg slotIndex: index destReg: destReg scratchReg: scratchReg
| jmpImmediate jmpDestYoung jmpSourceOld jmpAlreadyRoot mask rootBitByteOffset |
<var: #jmpImmediate type: #'AbstractInstruction *'>
<var: #jmpDestYoung type: #'AbstractInstruction *'>
<var: #jmpSourceOld type: #'AbstractInstruction *'>
<var: #jmpAlreadyRoot type: #'AbstractInstruction *'>
"do the store"
+ cogit MoveR: sourceReg Mw: index * objectMemory wordSize + objectMemory baseHeaderSize r: destReg.
- cogit MoveR: sourceReg Mw: index * BytesPerWord + BaseHeaderSize r: destReg.
"now the check. Is value stored an integer? If so we're done"
cogit MoveR: sourceReg R: scratchReg.
cogit AndCq: 1 R: scratchReg.
jmpImmediate := cogit JumpNonZero: 0.
"Get the old/new boundary in scratchReg"
cogit MoveAw: objectMemory youngStartAddress R: scratchReg.
"Is target young? If so we're done"
cogit CmpR: scratchReg R: destReg. "N.B. FLAGS := destReg - scratchReg"
jmpDestYoung := cogit JumpAboveOrEqual: 0.
"Is value stored old? If so we're done."
cogit CmpR: scratchReg R: sourceReg. "N.B. FLAGS := sourceReg - scratchReg"
jmpSourceOld := cogit JumpBelow: 0.
"value is young and target is old.
Need to make this a root if the root bit is not already set.
Test the root bit. Only need to fetch the byte containing it,
which reduces the size of the mask constant."
rootBitByteOffset := jmpSourceOld isBigEndian
+ ifTrue: [objectMemory wordSize - RootBitDigitLength]
- ifTrue: [BytesPerWord - RootBitDigitLength]
ifFalse:[RootBitDigitLength - 1].
mask := RootBitDigitLength > 1
ifTrue: [RootBit >> (RootBitDigitLength - 1 * 8)]
ifFalse: [RootBit].
"N.B. MoveMb:r:R: does not zero other bits"
cogit MoveMb: rootBitByteOffset r: destReg R: scratchReg.
cogit AndCq: mask R: scratchReg.
jmpAlreadyRoot := cogit JumpNonZero: 0.
"Root bit is not set. Call store check to insert dest into root table."
self assert: destReg == ReceiverResultReg.
cogit
CallRT: ceStoreCheckTrampoline
registersToBeSavedMask: ((cogit registerMaskFor: sourceReg)
bitAnd: cogit callerSavedRegMask).
jmpImmediate jmpTarget:
(jmpDestYoung jmpTarget:
(jmpSourceOld jmpTarget:
(jmpAlreadyRoot jmpTarget:
cogit Label))).
^0!
Item was changed:
----- Method: CogObjectRepresentationForSqueakV3>>genStoreSourceReg:slotIndex:intoNewObjectInDestReg: (in category 'compile abstract instructions') -----
genStoreSourceReg: sourceReg slotIndex: index intoNewObjectInDestReg: destReg
+ cogit MoveR: sourceReg Mw: index * objectMemory wordSize + objectMemory baseHeaderSize r: destReg.
- cogit MoveR: sourceReg Mw: index * BytesPerWord + BaseHeaderSize r: destReg.
^0!
Item was changed:
----- Method: CogObjectRepresentationForSqueakV3>>slotOffsetOfInstVarIndex: (in category 'compile abstract instructions') -----
slotOffsetOfInstVarIndex: index
+ ^index * objectMemory wordSize + objectMemory baseHeaderSize!
- ^index * BytesPerWord + BaseHeaderSize!
Item was changed:
----- Method: CogSistaMethodSurrogate32 class>>offsetOf: (in category 'accessing') -----
offsetOf: aByteSymbol
"These should be generated!!!!"
- self assert: self objectMemoryClass baseHeaderSize = BaseHeaderSize.
^aByteSymbol == #counters
+ ifTrue: [20 + self objectMemoryClass baseHeaderSize]
- ifTrue: [20 + BaseHeaderSize]
ifFalse: [super offsetOf: aByteSymbol]!
Item was changed:
----- Method: CogSistaMethodSurrogate64 class>>offsetOf: (in category 'accessing') -----
offsetOf: aByteSymbol
"These should be generated!!!!"
- self assert: self objectMemoryClass baseHeaderSize = BaseHeaderSize.
^aByteSymbol == #counters
+ ifTrue: [32 + self objectMemoryClass baseHeaderSize]
- ifTrue: [32 + BaseHeaderSize]
ifFalse: [super offsetOf: aByteSymbol]!
Item was changed:
----- Method: CogVMSimulator>>ceSendAbort:to:numArgs: (in category 'trampolines') -----
ceSendAbort: selector to: rcvr numArgs: numArgs
"self stringOf: selector"
"self printOop: rcvr"
self logSend: selector.
cogit assertCStackWellAligned.
self maybeCheckStackDepth: (selector = (objectMemory splObj: SelectorAboutToReturn)
ifTrue: [numArgs]
ifFalse: [numArgs + 1])
+ sp: stackPointer + objectMemory wordSize
- sp: stackPointer + BytesPerWord
pc: (stackPages longAt: stackPointer).
^super ceSendAbort: selector to: rcvr numArgs: numArgs!
Item was changed:
----- Method: CogVMSimulator>>clipboardWrite:From:At: (in category 'I/O primitives') -----
clipboardWrite: sz From: actualDataAddress At: ignored
+ Clipboard clipboardText: (self stringOf: actualDataAddress - objectMemory baseHeaderSize)!
- Clipboard clipboardText: (self stringOf: actualDataAddress - BaseHeaderSize)!
Item was changed:
----- Method: CogVMSimulator>>frameCallerContext: (in category 'frame access') -----
frameCallerContext: theFP
"In the StackInterpreter the saved ip field of a base frame holds the base
frame's caller context. But in the Cog VM the first word on the stack holds
the base frame's caller context, which is immediately above the stacked
receiver. The asserts using frameStackedReceiverOffset: are simulation
only since they depend on being able to access numArgs and frameContext
from the frame's method and in a base return the frame state, being below
the stack pointer, may have already been smashed by an interrupt."
| thePage |
self assert: (self isBaseFrame: theFP).
thePage := stackPages stackPageFor: theFP.
+ self assert: theFP + (self frameStackedReceiverOffset: theFP) + (2 * objectMemory wordSize) = thePage baseAddress.
+ self assert: (stackPages longAt: thePage baseAddress - objectMemory wordSize) = (self frameContext: theFP).
- self assert: theFP + (self frameStackedReceiverOffset: theFP) + (2 * BytesPerWord) = thePage baseAddress.
- self assert: (stackPages longAt: thePage baseAddress - BytesPerWord) = (self frameContext: theFP).
^super frameCallerContext: theFP!
Item was changed:
----- Method: CogVMSimulator>>isOnRumpCStack: (in category 'rump c stack') -----
isOnRumpCStack: address
+ ^address between: heapBase - self rumpCStackSize and: heapBase - objectMemory wordSize!
- ^address between: heapBase - self rumpCStackSize and: heapBase - BytesPerWord!
Item was changed:
----- Method: CogVMSimulator>>maybeCheckStackDepth:sp:pc: (in category 'debug support') -----
maybeCheckStackDepth: delta sp: sp pc: mcpc
| asp bcpc startbcpc cogHomeMethod cogBlockMethod csp debugStackPointers |
debugStackDepthDictionary ifNil: [^self].
(self isMachineCodeFrame: framePointer) ifFalse: [^self].
cogBlockMethod := self mframeCogMethod: framePointer.
cogHomeMethod := self asCogHomeMethod: cogBlockMethod.
debugStackPointers := debugStackDepthDictionary
at: cogHomeMethod methodObject
ifAbsentPut: [self debugStackPointersFor: cogHomeMethod methodObject].
startbcpc := cogHomeMethod = cogBlockMethod
ifTrue: [self startPCOfMethod: cogHomeMethod methodObject]
ifFalse: [self startPCOfClosure: (self pushedReceiverOrClosureOfFrame: framePointer)].
bcpc := cogit bytecodePCFor: mcpc startBcpc: startbcpc in: cogBlockMethod.
self assert: bcpc ~= 0.
cogBlockMethod ~= cogHomeMethod ifTrue:
[| lastbcpc |
lastbcpc := cogit lastBytecodePCForBlockAt: startbcpc in: cogHomeMethod methodObject.
bcpc > lastbcpc ifTrue:
[bcpc := lastbcpc]].
+ asp := self stackPointerIndexForFrame: framePointer WithSP: sp + objectMemory wordSize.
- asp := self stackPointerIndexForFrame: framePointer WithSP: sp + BytesPerWord.
csp := debugStackPointers at: bcpc.
"Compensate lazily for absent receiver sends."
(NewspeakVM
and: [asp - delta = csp
and: [cogit isAbsentReceiverSendAt: mcpc in: cogHomeMethod]]) ifTrue:
[csp := debugStackPointers at: bcpc put: csp + 1].
self assert: asp - delta + 1 = csp!
Item was changed:
----- Method: CogVMSimulator>>methodCacheSize (in category 'simulation only') -----
methodCacheSize
+ ^MethodCacheSize * objectMemory wordSize!
- ^MethodCacheSize * BytesPerWord!
Item was changed:
----- Method: CogVMSimulator>>moveMethodCacheToMemoryAt: (in category 'initialization') -----
moveMethodCacheToMemoryAt: address
| oldMethodCache |
oldMethodCache := methodCache.
self flag: 'broken for 64-bit VM because Bitmap access unit is 32-bits'.
"In the VM the methodCache is written as a normal array with 1-relative addressing.
In C this works by allocating an extra element in the methodCache array (see
class-side declareCVarsIn:). In simulation simply position the start of the methodCache
one word lower, achieving the same effect. -1 because CArrayAccessor is 0-relative
and adds 1 on accesses itself."
methodCache := CMethodCacheAccessor new
memory: objectMemory memory
+ offset: address / objectMemory wordSize
- offset: address / BytesPerWord
array: oldMethodCache
functionPointerIndex: MethodCachePrimFunction
entrySize: MethodCacheEntrySize.
1 to: MethodCacheSize do:
[:i|
self assert: (methodCache at: i) = 0].
methodCache at: 1 put: 16rC4EC4.
self assert: (self longAt: address) = 16rC4EC4.
1 to: MethodCacheSize do:
[:i|
methodCache at: i put: (oldMethodCache at: i)]!
Item was changed:
----- Method: CogVMSimulator>>movePrimTraceLogToMemoryAt: (in category 'initialization') -----
movePrimTraceLogToMemoryAt: address
| oldTraceLog |
oldTraceLog := primTraceLog.
self flag: 'broken for 64-bit VM because Bitmap access unit is 32-bits'.
primTraceLog := CObjectAccessor new
memory: objectMemory memory
+ offset: address / objectMemory wordSize.
- offset: address / BytesPerWord.
0 to: PrimTraceLogSize - 1 do:
[:i|
self assert: (primTraceLog at: i) = 0].
primTraceLog at: 0 put: 16rC4EC4.
self assert: (self longAt: address) = 16rC4EC4.
0 to: PrimTraceLogSize - 1 do:
[:i|
primTraceLog at: i put: (oldTraceLog at: i)]!
Item was changed:
----- Method: CogVMSimulator>>openOn:extraMemory: (in category 'initialization') -----
openOn: fileName extraMemory: extraBytes
"CogVMSimulator new openOn: 'clone.im' extraMemory: 100000"
| f version headerSize dataSize count oldBaseAddr bytesToShift swapBytes
headerFlags firstSegSize heapSize
hdrNumStackPages hdrEdenBytes hdrMaxExtSemTabSize
hdrCogCodeSize stackZoneSize methodCacheSize primTraceLogSize |
"open image file and read the header"
f := FileStream readOnlyFileNamed: fileName.
f ifNil: [^self error: 'no image found'].
["begin ensure block..."
imageName := f fullName.
f binary.
version := self nextLongFrom: f. "current version: 16r1968 (=6504) vive la revolucion!!"
(self readableFormat: version)
ifTrue: [swapBytes := false]
ifFalse: [(version := objectMemory byteSwapped: version) = self imageFormatVersion
ifTrue: [swapBytes := true]
ifFalse: [self error: 'incomaptible image format']].
headerSize := self getLongFromFile: f swap: swapBytes.
dataSize := self getLongFromFile: f swap: swapBytes. "length of heap in file"
oldBaseAddr := self getLongFromFile: f swap: swapBytes. "object memory base address of image"
objectMemory specialObjectsOop: (self getLongFromFile: f swap: swapBytes).
objectMemory lastHash: (self getLongFromFile: f swap: swapBytes). "Should be loaded from, and saved to the image header"
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"
numStackPages := desiredNumStackPages ~= 0
ifTrue: [desiredNumStackPages]
ifFalse: [hdrNumStackPages = 0
ifTrue: [self defaultNumStackPages]
ifFalse: [hdrNumStackPages]].
desiredNumStackPages := hdrNumStackPages.
stackZoneSize := self computeStackZoneSize.
"This slot holds the size of the native method zone in 1k units. (pad to word boundary)."
hdrCogCodeSize := (self getShortFromFile: f swap: swapBytes) * 1024.
cogCodeSize := desiredCogCodeSize ~= 0
ifTrue: [desiredCogCodeSize]
ifFalse:
[hdrCogCodeSize = 0
ifTrue: [self defaultCogCodeSize]
ifFalse: [hdrCogCodeSize]].
desiredCogCodeSize := hdrCogCodeSize.
self assert: f position = 40.
hdrEdenBytes := self getLongFromFile: f swap: swapBytes.
objectMemory edenBytes: (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].
"pad to word boundary. This slot can be used for anything else that will fit in 16 bits.
Preserve it to be polite to other VMs."
the2ndUnknownShort := self getShortFromFile: f swap: swapBytes.
self assert: f position = 48.
firstSegSize := self getLongFromFile: f swap: swapBytes.
objectMemory firstSegmentSize: firstSegSize.
"For Open PICs to be able to probe the method cache during
simulation the methodCache must be relocated to memory."
+ methodCacheSize := methodCache size * objectMemory wordSize.
+ primTraceLogSize := primTraceLog size * objectMemory wordSize.
- methodCacheSize := methodCache size * BytesPerWord.
- primTraceLogSize := primTraceLog size * BytesPerWord.
"allocate interpreter memory. This list is in address order, low to high.
In the actual VM the stack zone exists on the C stack."
heapBase := (Cogit guardPageSize
+ cogCodeSize
+ stackZoneSize
+ methodCacheSize
+ primTraceLogSize
+ self rumpCStackSize) roundUpTo: objectMemory allocationUnit.
heapSize := dataSize
+ extraBytes
+ objectMemory newSpaceBytes
+ self interpreterAllocationReserveBytes
+ (objectMemory hasSpurMemoryManagerAPI
ifTrue: [headerSize]
ifFalse: [0]).
heapBase := objectMemory
setHeapBase: heapBase
memoryLimit: heapBase + heapSize
endOfMemory: heapBase + dataSize.
self assert: cogCodeSize \\ 4 = 0.
self assert: objectMemory memoryLimit \\ 4 = 0.
self assert: self rumpCStackSize \\ 4 = 0.
"read in the image in bulk, then swap the bytes if necessary"
f position: headerSize.
objectMemory memory: ((cogit processor endianness == #little
ifTrue: [LittleEndianBitmap]
ifFalse: [Bitmap]) new: objectMemory memoryLimit // 4).
count := objectMemory readHeapFromImageFile: f dataBytes: dataSize.
count ~= dataSize ifTrue: [self halt].
]
ensure: [f close].
self moveMethodCacheToMemoryAt: objectMemory cogCodeBase + cogCodeSize + stackZoneSize.
self movePrimTraceLogToMemoryAt: objectMemory cogCodeBase + cogCodeSize + stackZoneSize + methodCacheSize.
self ensureImageFormatIsUpToDate: swapBytes.
bytesToShift := objectMemory memoryBaseForImageRead - oldBaseAddr. "adjust pointers for zero base address"
Utilities
informUser: 'Relocating object pointers...'
during: [self initializeInterpreter: bytesToShift].
self initializeCodeGenerator!
Item was changed:
----- Method: CogVMSimulator>>primTraceLogSize (in category 'simulation only') -----
primTraceLogSize
+ ^PrimTraceLogSize * objectMemory wordSize!
- ^PrimTraceLogSize * BytesPerWord!
Item was changed:
----- Method: CogVMSimulator>>printRumpCStackTo: (in category 'rump c stack') -----
printRumpCStackTo: address
self assert: (self isOnRumpCStack: address).
+ heapBase - objectMemory wordSize
- heapBase - BytesPerWord
to: address
+ by: objectMemory wordSize negated
- by: BytesPerWord negated
do:
[:addr|
self printHex: addr; tab; printHex: (self longAt: addr); cr]!
Item was changed:
----- Method: CogVMSimulator>>printStringOf:on: (in category 'debug printing') -----
printStringOf: oop on: aStream
| fmt cnt i |
(objectMemory isIntegerObject: oop) ifTrue:
[^nil].
(oop between: objectMemory startOfMemory and: objectMemory freeStart) ifFalse:
[^nil].
+ (oop bitAnd: (objectMemory wordSize - 1)) ~= 0 ifTrue:
- (oop bitAnd: (BytesPerWord - 1)) ~= 0 ifTrue:
[^nil].
fmt := objectMemory formatOf: oop.
fmt < 8 ifTrue: [ ^nil ].
cnt := 100 min: (objectMemory lengthOf: oop).
i := 0.
[i < cnt] whileTrue: [
aStream nextPut: (Character value: (objectMemory fetchByte: i ofObject: oop)).
i := i + 1.
].
aStream flush!
Item was changed:
----- Method: CogVMSimulator>>vmPathGet:Length: (in category 'file primitives') -----
vmPathGet: stringBase Length: stringSize
| pathName stringOop |
pathName := Smalltalk vmPath.
+ stringOop := stringBase - objectMemory baseHeaderSize. "Due to C call in Interp"
- stringOop := stringBase - 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: CogVMSimulatorLSB>>nextLongFrom: (in category 'initialization') -----
nextLongFrom: aStream
"Read a 32- or 64-bit quantity from the given (binary) stream."
+ ^ aStream nextLittleEndianNumber: objectMemory wordSize!
- ^ aStream nextLittleEndianNumber: BytesPerWord!
Item was changed:
----- Method: Cogit>>addressSpaceMask (in category 'accessing') -----
addressSpaceMask
<doNotGenerate>
"Quad-byte-align, because the ARM requires 4-byte aligned jump & call targets."
+ ^((1 << (8 * objectMemory wordSize)) - 1) bitAnd: -4!
- ^((1 << (8 * BytesPerWord)) - 1) bitAnd: -4!
Item was changed:
----- Method: Cogit>>allButTopBitOfAddressSpaceMask (in category 'accessing') -----
allButTopBitOfAddressSpaceMask
<doNotGenerate>
"Quad-byte-align, because the ARM requires 4-byte aligned jump & call targets."
+ ^((1 << (8 * objectMemory wordSize - 1)) - 1) bitAnd: -4!
- ^((1 << (8 * BytesPerWord - 1)) - 1) bitAnd: -4!
Item was changed:
----- Method: Cogit>>ceImplicitReceiverFor:receiver: (in category 'in-line cacheing') -----
ceImplicitReceiverFor: selector receiver: receiver
"Cached implicit receiver implementation. Caller looks like
mov selector, ClassReg
call ceImplicitReceiver
br continue
Lclass .word
Lmixin: .word
continue:
The trampoline has already fetched the class and probed the cache and found
that the cache missed. Compute the implicit receiver for the receiver's class
and reload the class tag. If either the class tag or the mixin are young then the
method needs to be added to the youngReferrers list to ensure correct GC."
<option: #SqueakV3ObjectMemory>
| rcvrClass retpc classpc mixinpc mixin cogMethod |
<var: #cogMethod type: #'CogMethod *'>
retpc := coInterpreter stackTop.
classpc := retpc + backEnd jumpShortByteSize.
+ mixinpc := retpc + backEnd jumpShortByteSize + objectMemory bytesPerOop.
- mixinpc := retpc + backEnd jumpShortByteSize + BytesPerOop.
mixin := coInterpreter
implicitReceiverFor: receiver
mixin: coInterpreter mMethodClass
implementing: selector.
rcvrClass := objectMemory fetchClassOf: receiver.
cogMethod := coInterpreter mframeHomeMethodExport.
cogMethod cmRefersToYoung ifFalse:
[((objectRepresentation inlineCacheTagsMayBeObjects
and: [objectMemory isYoung: rcvrClass])
or: [mixin ~= receiver and: [objectMemory isYoung: mixin]]) ifTrue:
[methodZone ensureInYoungReferrers: cogMethod]].
backEnd
unalignedLongAt: classpc
put: (objectRepresentation inlineCacheTagForClass: rcvrClass);
unalignedLongAt: mixinpc
put: (mixin = receiver ifTrue: [0] ifFalse: [mixin]).
^mixin!
Item was changed:
----- Method: Cogit>>ceImplicitReceiverFor:receiver:cache: (in category 'in-line cacheing') -----
ceImplicitReceiverFor: selector receiver: receiver cache: cacheAddress
"Cached implicit receiver implementation. Caller looks like
mov Lclass, Arg1Reg
mov selector, SendNumArgsReg
call ceImplicitReceiver
and Lclass: .word; Lmixin: .word is somewhere on the heap.
The trampoline has already fetched the class and probed the cache and found
that the cache missed. Compute the implicit receiver for the receiver's class
and reload the class tag. If either the class tag or the mixin are young then the
method needs to be added to the youngReferrers list to ensure correct GC."
<option: #SpurObjectMemory>
<var: #cacheAddress type: #usqInt>
| rcvrClass mixin cogMethod |
<var: #cogMethod type: #'CogMethod *'>
mixin := coInterpreter
implicitReceiverFor: receiver
mixin: coInterpreter mMethodClass
implementing: selector.
rcvrClass := objectMemory fetchClassOf: receiver.
cogMethod := coInterpreter mframeHomeMethodExport.
cogMethod cmRefersToYoung ifFalse:
[((objectRepresentation inlineCacheTagsMayBeObjects
and: [objectMemory isYoung: rcvrClass])
or: [mixin ~= receiver and: [objectMemory isYoung: mixin]]) ifTrue:
[methodZone ensureInYoungReferrers: cogMethod]].
backEnd
unalignedLongAt: cacheAddress
put: (objectRepresentation inlineCacheTagForClass: rcvrClass);
+ unalignedLongAt: cacheAddress + objectMemory bytesPerOop
- unalignedLongAt: cacheAddress + BytesPerOop
put: (mixin = receiver ifTrue: [0] ifFalse: [mixin]).
^mixin!
Item was changed:
----- Method: Cogit>>cogBlockMethodSurrogateAt: (in category 'simulation only') -----
cogBlockMethodSurrogateAt: address
<doNotGenerate>
+ self assert: (address bitAnd: objectMemory wordSize - 1) = 0.
- self assert: (address bitAnd: BytesPerWord - 1) = 0.
^cogBlockMethodSurrogateClass new
at: address
objectMemory: objectMemory
cogit: self!
Item was changed:
----- Method: Cogit>>cogMethodDoesntLookKosher: (in category 'debugging') -----
cogMethodDoesntLookKosher: cogMethod
"Check that the header fields onf a non-free method are consistent with
the type. Answer 0 if it is ok, otherwise answer a code for the error."
<api>
<inline: false>
<var: #cogMethod type: #'CogMethod *'>
+ ((cogMethod blockSize bitAnd: objectMemory wordSize - 1) ~= 0
- ((cogMethod blockSize bitAnd: BytesPerWord - 1) ~= 0
or: [cogMethod blockSize < (self sizeof: CogMethod)
or: [cogMethod blockSize >= 32768]]) ifTrue:
[^1].
cogMethod cmType = CMFree ifTrue: [^2].
cogMethod cmType = CMMethod ifTrue:
[(objectMemory isIntegerObject: cogMethod methodHeader) ifFalse:
[^11].
(objectRepresentation couldBeObject: cogMethod methodObject) ifFalse:
[^12].
(cogMethod stackCheckOffset > 0
and: [cogMethod stackCheckOffset < cmNoCheckEntryOffset]) ifTrue:
[^13].
^0].
cogMethod cmType = CMOpenPIC ifTrue:
[cogMethod blockSize ~= openPICSize ifTrue:
[^21].
cogMethod methodHeader ~= 0 ifTrue:
[^22].
"Check the nextOpenPIC link unless we're compacting"
cogMethod objectHeader >= 0 ifTrue:
[(cogMethod methodObject ~= 0
and: [cogMethod methodObject < methodZoneBase
or: [cogMethod methodObject > (methodZone freeStart - openPICSize)
+ or: [(cogMethod methodObject bitAnd: objectMemory wordSize - 1) ~= 0
- or: [(cogMethod methodObject bitAnd: BytesPerWord - 1) ~= 0
or: [(self cCoerceSimple: cogMethod methodObject
to: #'CogMethod *') cmType ~= CMOpenPIC]]]]) ifTrue:
[^23]].
cogMethod stackCheckOffset ~= 0 ifTrue:
[^24].
^0].
cogMethod cmType = CMClosedPIC ifTrue:
[cogMethod blockSize ~= closedPICSize ifTrue:
[^31].
(cogMethod cPICNumCases between: 1 and: numPICCases) ifFalse:
[^32].
cogMethod methodHeader ~= 0 ifTrue:
[^33].
cogMethod methodObject ~= 0 ifTrue:
[^34].
^0].
^9!
Item was changed:
----- Method: Cogit>>cogMethodSurrogateAt: (in category 'simulation only') -----
cogMethodSurrogateAt: address
<doNotGenerate>
+ self assert: (address < 0 or: [(address bitAnd: objectMemory wordSize - 1) = 0]).
- self assert: (address < 0 or: [(address bitAnd: BytesPerWord - 1) = 0]).
^cogMethodSurrogateClass new
at: address
objectMemory: objectMemory
cogit: self!
Item was changed:
----- Method: Cogit>>compileBlockEntry: (in category 'compile abstract instructions') -----
compileBlockEntry: blockStart
"Compile a block's entry. This looks like a dummy CogBlockMethod header (for frame parsing)
followed by either a frame build, if a frame is required, or nothing. The CogMethodHeader's
objectHeader field is a back pointer to the method, but this can't be filled in until code generation."
<var: #blockStart type: #'BlockStart *'>
self AlignmentNops: self blockAlignment.
blockStart fakeHeader: self Label.
(self sizeof: CogBlockMethod) caseOf:
+ { [2 * objectMemory wordSize] "ObjectMemory"
- { [2 * BytesPerWord] "ObjectMemory"
-> [self Fill32: 0. "gets filled in later with the homeOffset and startpc"
self Fill32: 0]. "gets filled in later with numArgs et al"
+ [3 * objectMemory wordSize] "Spur"
- [3 * BytesPerWord] "Spur"
-> [self Fill32: 0. "gets filled in later with the homeOffset and startpc"
self Fill32: 0. "is left fallow"
self Fill32: 0]. "gets filled in later with numArgs et al"
}.
blockStart entryLabel: self Label.
needsFrame
ifTrue:
[self compileBlockFrameBuild: blockStart.
self recordBlockTrace ifTrue:
[self CallRT: ceTraceBlockActivationTrampoline]]
ifFalse:
[self compileBlockFramelessEntry: blockStart]!
Item was changed:
----- Method: Cogit>>compileCallFor:numArgs:arg:arg:arg:arg:resultReg:saveRegs: (in category 'initialization') -----
compileCallFor: aRoutine numArgs: numArgs arg: regOrConst0 arg: regOrConst1 arg: regOrConst2 arg: regOrConst3 resultReg: resultRegOrNil saveRegs: saveRegs
"Generate a call to aRoutine with up to 4 arguments. If resultRegOrNil is
non-zero assign the C result to resultRegOrNil. If saveRegs, save all registers.
Hack: a negative arg value indicates an abstract register, a non-negative value
indicates a constant."
<var: #aRoutine type: #'void *'>
<inline: false>
+ cStackAlignment > objectMemory wordSize ifTrue:
- cStackAlignment > BytesPerWord ifTrue:
[backEnd
genAlignCStackSavingRegisters: saveRegs
numArgs: numArgs
+ wordAlignment: cStackAlignment / objectMemory wordSize].
- wordAlignment: cStackAlignment / BytesPerWord].
saveRegs ifTrue:
[backEnd genSaveRegisters].
numArgs > 0 ifTrue:
[numArgs > 1 ifTrue:
[numArgs > 2 ifTrue:
[numArgs > 3 ifTrue:
[regOrConst3 < 0
ifTrue: [backEnd genPassReg: regOrConst3 asArgument: 3]
ifFalse: [backEnd genPassConst: regOrConst3 asArgument: 3]].
regOrConst2 < 0
ifTrue: [backEnd genPassReg: regOrConst2 asArgument: 2]
ifFalse: [backEnd genPassConst: regOrConst2 asArgument: 2]].
regOrConst1 < 0
ifTrue: [backEnd genPassReg: regOrConst1 asArgument: 1]
ifFalse: [backEnd genPassConst: regOrConst1 asArgument: 1]].
regOrConst0 < 0
ifTrue: [backEnd genPassReg: regOrConst0 asArgument: 0]
ifFalse: [backEnd genPassConst: regOrConst0 asArgument: 0]].
self CallRT: (self cCode: [aRoutine asUnsignedInteger]
inSmalltalk: [self simulatedTrampolineFor: aRoutine]).
resultRegOrNil ifNotNil:
[backEnd genWriteCResultIntoReg: resultRegOrNil].
saveRegs ifTrue:
[numArgs > 0 ifTrue:
[backEnd genRemoveNArgsFromStack: numArgs].
resultRegOrNil
ifNotNil: [backEnd genRestoreRegsExcept: resultRegOrNil]
ifNil: [backEnd genRestoreRegs]]!
Item was changed:
----- Method: Cogit>>computeEntryOffsets (in category 'initialization') -----
computeEntryOffsets
"Generate the entry code for a method to determine cmEntryOffset and cmNoCheckEntryOffset. We
need cmNoCheckEntryOffset up front to be able to generate the map starting from cmNoCheckEntryOffset"
"stack allocate the various collections so that they
are effectively garbage collected on return."
self allocateOpcodes: 20 bytecodes: 0.
methodOrBlockNumArgs := 0.
self compileAbort.
self compileEntry.
self computeMaximumSizes.
self generateInstructionsAt: methodZoneBase + (self sizeof: CogMethod).
cmEntryOffset := entry address - methodZoneBase.
cmNoCheckEntryOffset := noCheckEntry address - methodZoneBase.
self cppIf: NewspeakVM
ifTrue: [cmDynSuperEntryOffset := dynSuperEntry address - methodZoneBase].
missOffset := sendMissCall address + sendMissCall machineCodeSize - methodZoneBase.
+ entryPointMask := objectMemory wordSize - 1.
- entryPointMask := BytesPerWord - 1.
[self cppIf: NewspeakVM
ifTrue: [(cmEntryOffset bitAnd: entryPointMask) = (cmNoCheckEntryOffset bitAnd: entryPointMask)
or: [(cmEntryOffset bitAnd: entryPointMask) = (cmDynSuperEntryOffset bitAnd: entryPointMask)
or: [(cmNoCheckEntryOffset bitAnd: entryPointMask) = (cmDynSuperEntryOffset bitAnd: entryPointMask)]]]
ifFalse: [(cmEntryOffset bitAnd: entryPointMask) = (cmNoCheckEntryOffset bitAnd: entryPointMask)]] whileTrue:
[entryPointMask := entryPointMask + entryPointMask + 1].
entryPointMask >= (methodZone roundUpLength: 1) ifTrue:
[self error: 'cannot differentiate checked and unchecked entry-points with current cog method alignment'].
checkedEntryAlignment := cmEntryOffset bitAnd: entryPointMask.
uncheckedEntryAlignment := cmNoCheckEntryOffset bitAnd: entryPointMask.
self assert: checkedEntryAlignment ~= uncheckedEntryAlignment.
self cppIf: NewspeakVM
ifTrue:
[cmDynSuperEntryOffset := dynSuperEntry address - methodZoneBase.
dynSuperEntryAlignment := cmDynSuperEntryOffset bitAnd: entryPointMask.
self assert: dynSuperEntryAlignment ~= checkedEntryAlignment.
self assert: dynSuperEntryAlignment ~= uncheckedEntryAlignment]!
Item was changed:
----- Method: Cogit>>disassembleMethod:on: (in category 'disassembly') -----
disassembleMethod: surrogateOrAddress on: aStream
<doNotGenerate>
| cogMethod mapEntries codeRanges |
cogMethod := surrogateOrAddress isInteger
ifTrue: [self cogMethodSurrogateAt: surrogateOrAddress]
ifFalse: [surrogateOrAddress].
cogMethod cmType = CMBlock ifTrue:
[^self disassembleMethod: cogMethod cmHomeMethod on: aStream].
self printMethodHeader: cogMethod on: aStream.
(mapEntries := Dictionary new)
at: cogMethod asInteger + cmEntryOffset put: 'entry'.
cogMethod cmType = CMMethod ifTrue:
[mapEntries at: cogMethod asInteger + cmNoCheckEntryOffset put: 'noCheckEntry'.
self cppIf: NewspeakVM
ifTrue: [mapEntries at: cogMethod asInteger + dynSuperEntryAlignment put: 'dynSuperEntry']].
cogMethod cmType = CMClosedPIC ifTrue:
[mapEntries at: cogMethod asInteger + firstCPICCaseOffset put: 'ClosedPICCase0'.
1 to: numPICCases - 1 do:
[:i|
mapEntries
at: cogMethod asInteger + firstCPICCaseOffset + (i * cPICCaseSize)
put: 'ClosedPICCase', i printString]].
self mapFor: cogMethod
performUntil: #collectMapEntry:address:into:
arg: mapEntries.
self cppIf: NewspeakVM
ifTrue:
[objectRepresentation canPinObjects ifFalse:
[mapEntries keys do:
[:a|
(mapEntries at: a) = #IsNSSendCall ifTrue:
[mapEntries
at: a + backEnd jumpShortByteSize
+ put: {'Class'. #disassembleCachedOop:. (objectMemory wordSize)};
+ at: a + backEnd jumpShortByteSize + objectMemory bytesPerOop
+ put: {'ImplicitReceiver'. #disassembleCachedOop:. (objectMemory wordSize)}]]]].
- put: {'Class'. #disassembleCachedOop:. BytesPerWord};
- at: a + backEnd jumpShortByteSize + BytesPerOop
- put: {'ImplicitReceiver'. #disassembleCachedOop:. BytesPerWord}]]]].
"This would all be far more elegant and simple if we used blocks.
But there are no blocks in C and the basic enumerators here need
to be used in the real VM. Apologies."
(codeRanges := self codeRangesFor: cogMethod) do:
[:range|
(cogMethod cmType = CMMethod) ifTrue:
[mapEntries keysAndValuesDo:
[:mcpc :label| | bcpc |
((range includes: mcpc)
and: [(#(IsSendCall HasBytecodePC) includes: label)
and: [range cogMethod stackCheckOffset > 0]]) ifTrue:
[bcpc := self bytecodePCFor: mcpc startBcpc: range startpc in: range cogMethod.
bcpc ~= 0 ifTrue:
[mapEntries at: mcpc put: label, ' bc ', bcpc printString, '/', (bcpc + 1) printString]]]].
(cogMethod blockEntryOffset ~= 0
and: [range first = (cogMethod blockEntryOffset + cogMethod asInteger)])
ifTrue:
[aStream nextPutAll: 'blockEntry:'; cr.
self blockDispatchFor: cogMethod
perform: #disassemble:from:to:arg:
arg: aStream]
ifFalse:
[range first > (cogMethod address + cmNoCheckEntryOffset) ifTrue:
[self printMethodHeader: range cogMethod
on: aStream].
self disassembleFrom: range first to: range last labels: mapEntries on: aStream]].
aStream nextPutAll: 'startpc: '; print: codeRanges first startpc; cr.
(cogMethod cmType = CMMethod
or: [cogMethod cmType = CMOpenPIC]) ifTrue:
[[self mapFor: cogMethod
performUntil: #printMapEntry:mcpc:args:
arg: { aStream. codeRanges. cogMethod }]
on: AssertionFailure
do: [:ex|
ex primitiveChangeClassTo: ResumableVMError basicNew. ":) :) :)"
ex resume: nil]].
^cogMethod!
Item was changed:
----- Method: Cogit>>generateNewspeakRuntime (in category 'initialization') -----
generateNewspeakRuntime
<option: #NewspeakVM>
| jumpMiss jumpItsTheReceiverStupid retpcReg |
<var: #jumpMiss type: #'AbstractInstruction *'>
<var: #jumpItsTheReceiverStupid type: #'AbstractInstruction *'>
"Generate the non-send runtime support for Newspeak, explicit outer and implicit receiver.
The dynamic frequency of explicit outer is so low we merely call an interpreter routine."
ceEnclosingObjectTrampoline := self genTrampolineFor: #ceEnclosingObjectAt:
called: 'ceEnclosingObjectTrampoline'
arg: SendNumArgsReg
result: ReceiverResultReg.
"Cached push implicit receiver implementation. If objectRepresentation doesn't support
pinning then caller looks like
mov selector, SendNumArgsReg
call ceImplicitReceiver
br continue
Lclass: .word
Lmixin:: .word
continue:
If objectRepresentation supports pinning then caller looks like
mov Lclass, Arg1Reg
mov selector, SendNumArgsReg
call ceImplicitReceiver
and Lclass: .word; Lmixin: .word is somewhere on the heap.
If class tag matches class of receiver then mixin contains either 0 or the implicit receiver.
If 0, answer the actual receiver, otherwise the mixin.
Generate the class fetch and cache probe inline for speed.
Smashes Arg1Reg, RegClass and caller-saved regs."
opcodeIndex := 0.
self MoveMw: FoxMFReceiver r: FPReg R: ReceiverResultReg.
objectRepresentation
genGetInlineCacheClassTagFrom: ReceiverResultReg
into: ClassReg
forEntry: false.
objectRepresentation canPinObjects
ifTrue:
[self MoveMw: 0 r: Arg1Reg R: TempReg.
self CmpR: ClassReg R: TempReg.
jumpMiss := self JumpNonZero: 0.
+ self MoveMw: objectMemory bytesPerOop r: Arg1Reg R: TempReg.
- self MoveMw: BytesPerOop r: Arg1Reg R: TempReg.
self CmpCq: 0 R: TempReg.
jumpItsTheReceiverStupid := self JumpZero: 0.
self MoveR: TempReg R: ReceiverResultReg.
jumpItsTheReceiverStupid jmpTarget: (self RetN: 0).
jumpMiss jmpTarget: self Label.
objectRepresentation
genEnsureObjInRegNotForwarded: ReceiverResultReg
scratchReg: TempReg
updatingMw: FoxMFReceiver
r: FPReg.
ceImplicitReceiverTrampoline := self
genTrampolineFor: #ceImplicitReceiverFor:receiver:cache:
called: 'ceImplicitReceiverTrampoline'
numArgs: 3
arg: SendNumArgsReg
arg: ReceiverResultReg
arg: Arg1Reg
arg: nil
saveRegs: false
pushLinkReg: true
resultReg: ReceiverResultReg
appendOpcodes: true]
ifFalse:
[backEnd hasLinkRegister
ifTrue: [retpcReg := LinkReg]
ifFalse: [self MoveMw: 0 r: SPReg R: (retpcReg := TempReg)].
self MoveMw: 0 r: SPReg R: retpcReg.
self MoveMw: backEnd jumpShortByteSize r: retpcReg R: Arg1Reg.
self CmpR: ClassReg R: Arg1Reg.
jumpMiss := self JumpNonZero: 0.
+ self MoveMw: backEnd jumpShortByteSize + objectMemory bytesPerOop r: retpcReg R: ClassReg.
- self MoveMw: backEnd jumpShortByteSize + BytesPerOop r: retpcReg R: ClassReg.
self CmpCq: 0 R: ClassReg.
jumpItsTheReceiverStupid := self JumpZero: 0.
self MoveR: ClassReg R: ReceiverResultReg.
jumpItsTheReceiverStupid jmpTarget: (self RetN: 0).
jumpMiss jmpTarget: self Label.
ceImplicitReceiverTrampoline := self
genTrampolineFor: #ceImplicitReceiverFor:receiver:
called: 'ceImplicitReceiverTrampoline'
numArgs: 2
arg: SendNumArgsReg
arg: ReceiverResultReg
arg: nil
arg: nil
saveRegs: false
pushLinkReg: true
resultReg: ReceiverResultReg
appendOpcodes: true]!
Item was changed:
----- Method: Cogit>>handleCallOrJumpSimulationTrap: (in category 'simulation only') -----
handleCallOrJumpSimulationTrap: aProcessorSimulationTrap
<doNotGenerate>
| evaluable function result savedFramePointer savedStackPointer savedArgumentCount rpc |
evaluable := simulatedTrampolines at: aProcessorSimulationTrap address.
function := evaluable
isBlock ifTrue: ['aBlock; probably some plugin primitive']
ifFalse: [evaluable selector].
function ~~ #ceBaseFrameReturn: ifTrue:
[coInterpreter assertValidExternalStackPointers].
(function beginsWith: 'ceShort') ifTrue:
[^self perform: function with: aProcessorSimulationTrap].
aProcessorSimulationTrap type = #call
ifTrue:
[processor
simulateCallOf: aProcessorSimulationTrap address
nextpc: aProcessorSimulationTrap nextpc
memory: coInterpreter memory.
self recordInstruction: {'(simulated call of '. aProcessorSimulationTrap address. '/'. function. ')'}]
ifFalse:
[processor
simulateJumpCallOf: aProcessorSimulationTrap address
memory: coInterpreter memory.
self recordInstruction: {'(simulated jump to '. aProcessorSimulationTrap address. '/'. function. ')'}].
savedFramePointer := coInterpreter framePointer.
savedStackPointer := coInterpreter stackPointer.
savedArgumentCount := coInterpreter argumentCount.
result := ["self halt: evaluable selector."
evaluable valueWithArguments: (processor
postCallArgumentsNumArgs: evaluable numArgs
in: coInterpreter memory)]
on: ReenterMachineCode
do: [:ex| ex return: ex returnValue].
coInterpreter assertValidExternalStackPointers.
"Verify the stack layout assumption compileInterpreterPrimitive: makes, provided we've
not called something that has built a frame, such as closure value or evaluate method, or
switched frames, such as primitiveSignal, primitiveWait, primitiveResume, primitiveSuspend et al."
(function beginsWith: 'primitive') ifTrue:
[coInterpreter checkForLastObjectOverwrite.
coInterpreter primFailCode = 0
ifTrue: [(#( primitiveClosureValue primitiveClosureValueWithArgs primitiveClosureValueNoContextSwitch
primitiveSignal primitiveWait primitiveResume primitiveSuspend primitiveYield
primitiveExecuteMethodArgsArray primitiveExecuteMethod
primitivePerform primitivePerformWithArgs primitivePerformInSuperclass
primitiveTerminateTo primitiveStoreStackp primitiveDoPrimitiveWithArgs)
includes: function) ifFalse:
[self assert: savedFramePointer = coInterpreter framePointer.
+ self assert: savedStackPointer + (savedArgumentCount * objectMemory wordSize)
- self assert: savedStackPointer + (savedArgumentCount * BytesPerWord)
= coInterpreter stackPointer]]
ifFalse:
[self assert: savedFramePointer = coInterpreter framePointer.
self assert: savedStackPointer = coInterpreter stackPointer]].
result ~~ #continueNoReturn ifTrue:
[self recordInstruction: {'(simulated return to '. processor retpcIn: coInterpreter memory. ')'}.
rpc := processor retpcIn: coInterpreter memory.
self assert: (rpc >= codeBase and: [rpc < methodZone freeStart]).
processor
+ smashCallerSavedRegistersWithValuesFrom: 16r80000000 by: objectMemory wordSize;
- smashCallerSavedRegistersWithValuesFrom: 16r80000000 by: BytesPerWord;
simulateReturnIn: coInterpreter memory].
self assert: (result isInteger "an oop result"
or: [result == coInterpreter
or: [result == objectMemory
or: [#(nil continue continueNoReturn) includes: result]]]).
processor cResultRegister: (result
ifNil: [0]
ifNotNil: [result isInteger
ifTrue: [result]
ifFalse: [16rF00BA222]])
"coInterpreter cr.
processor sp + 32 to: processor sp - 32 by: -4 do:
[:sp|
sp = processor sp
ifTrue: [coInterpreter print: 'sp->'; tab]
ifFalse: [coInterpreter printHex: sp].
coInterpreter tab; printHex: (coInterpreter longAt: sp); cr]"!
Item was changed:
----- Method: Cogit>>initialize (in category 'initialization') -----
initialize
+ | wordSize |
+ wordSize := self class objectMemoryClass wordSize.
cogMethodSurrogateClass := NewspeakVM
ifTrue:
+ [wordSize = 4
- [BytesPerWord = 4
ifTrue: [NewspeakCogMethodSurrogate32]
ifFalse: [NewspeakCogMethodSurrogate64]]
ifFalse:
+ [wordSize = 4
- [BytesPerWord = 4
ifTrue: [CogMethodSurrogate32]
ifFalse: [CogMethodSurrogate64]].
+ cogBlockMethodSurrogateClass := wordSize = 4
- cogBlockMethodSurrogateClass := BytesPerWord = 4
ifTrue: [CogBlockMethodSurrogate32]
ifFalse: [CogBlockMethodSurrogate64]!
Item was changed:
----- Method: Cogit>>mapObjectReferencesInMachineCodeForYoungGC (in category 'garbage collection') -----
mapObjectReferencesInMachineCodeForYoungGC
"Update all references to objects in machine code for either a Spur scavenging gc
or a Squeak V3 incremental GC. Avoid scanning all code by using the youngReferrers
list. In a young gc a method referring to young may no longer refer to young, but a
method not referring to young cannot and will not refer to young afterwards."
| pointer cogMethod hasYoungObj hasYoungObjPtr |
<var: #cogMethod type: #'CogMethod *'>
hasYoungObj := false.
hasYoungObjPtr := (self addressOf: hasYoungObj put: [:val| hasYoungObj := val]) asInteger.
codeModified := false.
pointer := methodZone youngReferrers.
[pointer < methodZone zoneEnd] whileTrue:
[self assert: hasYoungObj not.
cogMethod := coInterpreter cCoerceSimple: (objectMemory longAt: pointer) to: #'CogMethod *'.
cogMethod cmType = CMFree
ifTrue: [self assert: cogMethod cmRefersToYoung not]
ifFalse:
[self assert: (self cogMethodDoesntLookKosher: cogMethod) = 0.
cogMethod cmRefersToYoung ifTrue:
[self assert: (cogMethod cmType = CMMethod
or: [cogMethod cmType = CMOpenPIC]).
cogMethod selector: (objectRepresentation remapOop: cogMethod selector).
(objectMemory isYoung: cogMethod selector) ifTrue:
[hasYoungObj := true].
cogMethod cmType = CMMethod ifTrue:
[self assert: cogMethod objectHeader = objectMemory nullHeaderForMachineCodeMethod.
cogMethod methodObject: (objectRepresentation remapOop: cogMethod methodObject).
(objectMemory isYoung: cogMethod methodObject) ifTrue:
[hasYoungObj := true]].
self mapFor: cogMethod
performUntil: #remapIfObjectRef:pc:hasYoung:
arg: hasYoungObjPtr.
hasYoungObj
ifTrue: [hasYoungObj := false]
ifFalse: [cogMethod cmRefersToYoung: false]]].
+ pointer := pointer + objectMemory wordSize].
- pointer := pointer + BytesPerWord].
methodZone pruneYoungReferrers.
codeModified ifTrue: "After updating oops in inline caches we need to flush the icache."
[processor flushICacheFrom: methodZoneBase to: methodZone limitZony asInteger]!
Item was changed:
----- Method: Cogit>>markAndTraceMachineCodeForNewSpaceGC (in category 'jit - api') -----
markAndTraceMachineCodeForNewSpaceGC
"Free any methods that refer to unmarked objects, unlinking sends to freed methods."
| pointer cogMethod |
<var: #cogMethod type: #'CogMethod *'>
objectMemory leakCheckNewSpaceGC ifTrue:
[self assert: self allMachineCodeObjectReferencesValid].
codeModified := false.
pointer := methodZone youngReferrers.
[pointer < methodZone zoneEnd] whileTrue:
[cogMethod := coInterpreter cCoerceSimple: (objectMemory longAt: pointer) to: #'CogMethod *'.
cogMethod cmRefersToYoung ifTrue:
[self assert: (self cogMethodDoesntLookKosher: cogMethod) = 0.
self assert: (cogMethod cmType = CMMethod
or: [cogMethod cmType = CMOpenPIC]).
(objectMemory isYoung: cogMethod selector) ifTrue:
[objectMemory markAndTrace: cogMethod selector].
cogMethod cmType = CMMethod ifTrue:
[(objectMemory isYoung: cogMethod methodObject) ifTrue:
[objectMemory markAndTrace: cogMethod methodObject].
self markYoungObjectsIn: cogMethod]].
+ pointer := pointer + objectMemory wordSize].
- pointer := pointer + BytesPerWord].
objectMemory leakCheckIncrementalGC ifTrue:
[self assert: self allMachineCodeObjectReferencesValid].
codeModified ifTrue: "After updating oops in inline caches we need to flush the icache."
[processor flushICacheFrom: methodZoneBase to: methodZone limitZony asInteger]!
Item was changed:
----- Method: Cogit>>markLiterals:pc:method: (in category 'garbage collection') -----
markLiterals: annotation pc: mcpc method: cogMethod
"Mark and trace literals.
Additionally in Newspeak, void push implicits that have unmarked classes."
<var: #mcpc type: #'char *'>
| literal |
annotation = IsObjectReference ifTrue:
[literal := backEnd literalBeforeFollowingAddress: mcpc asUnsignedInteger.
(objectRepresentation
markAndTraceLiteral: literal
in: (self cCoerceSimple: cogMethod to: #'CogMethod *')
atpc: mcpc asUnsignedInteger) ifTrue:
[codeModified := true]].
(self isSendAnnotation: annotation) ifTrue:
[self offsetCacheTagAndCouldBeObjectAt: mcpc annotation: annotation into:
[:entryPoint :cacheTag :tagCouldBeObj |
tagCouldBeObj ifTrue:
[(objectRepresentation
markAndTraceCacheTagLiteral: cacheTag
in: (self cCoerceSimple: cogMethod to: #'CogMethod *')
atpc: mcpc asUnsignedInteger) ifTrue:
[codeModified := true]]. "cacheTag is selector"
self cppIf: NewspeakVM ifTrue:
[entryPoint = ceImplicitReceiverTrampoline ifTrue:
[| cacheAddress class mixin |
self assert: NumOopsPerIRC = 2.
cacheAddress := self implicitReceiverCacheAddressAt: mcpc.
(class := backEnd unalignedLongAt: cacheAddress) ~= 0
ifTrue:
[(objectRepresentation cacheTagIsMarked: class)
ifTrue:
+ [(mixin := backEnd unalignedLongAt: cacheAddress + objectMemory bytesPerOop) ~= 0 ifTrue:
- [(mixin := backEnd unalignedLongAt: cacheAddress + BytesPerOop) ~= 0 ifTrue:
[objectRepresentation
markAndTraceLiteral: mixin
in: (self cCoerceSimple: cogMethod to: #'CogMethod *')
+ at: (self asAddress: cacheAddress + objectMemory bytesPerOop
+ put: [:val| backEnd unalignedLongAt: cacheAddress + objectMemory bytesPerOop put: val])]]
- at: (self asAddress: cacheAddress + BytesPerOop
- put: [:val| backEnd unalignedLongAt: cacheAddress + BytesPerOop put: val])]]
ifFalse:
[backEnd
unalignedLongAt: cacheAddress put: 0;
+ unalignedLongAt: cacheAddress + objectMemory bytesPerOop put: 0.
- unalignedLongAt: cacheAddress + BytesPerOop put: 0.
codeModified := true]]
ifFalse:
+ [self assert: (backEnd unalignedLongAt: cacheAddress + objectMemory bytesPerOop) = 0]]]]].
- [self assert: (backEnd unalignedLongAt: cacheAddress + BytesPerOop) = 0]]]]].
^0 "keep scanning"!
Item was changed:
----- Method: Cogit>>markLiteralsAndUnlinkIfUnmarkedSend:pc:method: (in category 'garbage collection') -----
markLiteralsAndUnlinkIfUnmarkedSend: annotation pc: mcpc method: cogMethod
"Mark and trace literals. Unlink sends that have unmarked cache tags or targets."
<var: #mcpc type: #'char *'>
| literal |
annotation = IsObjectReference ifTrue:
[literal := backEnd literalBeforeFollowingAddress: mcpc asUnsignedInteger.
(objectRepresentation
markAndTraceLiteral: literal
in: (self cCoerceSimple: cogMethod to: #'CogMethod *')
atpc: mcpc asUnsignedInteger) ifTrue:
[codeModified := true]].
(self isSendAnnotation: annotation) ifTrue:
[self offsetCacheTagAndCouldBeObjectAt: mcpc annotation: annotation into:
[:entryPoint :cacheTag :tagCouldBeObj | | cacheTagMarked |
cacheTagMarked := tagCouldBeObj and: [objectRepresentation cacheTagIsMarked: cacheTag].
entryPoint > methodZoneBase
ifTrue: "It's a linked send."
[self targetMethodAndSendTableFor: entryPoint into:
[:targetMethod :sendTable|
(cacheTagMarked not
or: [self markAndTraceOrFreeCogMethod: targetMethod
firstVisit: targetMethod asUnsignedInteger > mcpc asUnsignedInteger]) ifTrue:
["Either the cacheTag is unmarked (e.g. new class) or the target
has been freed (because it is unmarked), so unlink the send."
self unlinkSendAt: mcpc targetMethod: targetMethod sendTable: sendTable.
objectRepresentation
markAndTraceLiteral: targetMethod selector
in: targetMethod
at: (self addressOf: targetMethod selector put: [:val| targetMethod selector: val])]]]
ifFalse: "cacheTag is selector"
[(objectRepresentation
markAndTraceCacheTagLiteral: cacheTag
in: cogMethod
atpc: mcpc asUnsignedInteger) ifTrue:
[codeModified := true].
self cppIf: NewspeakVM ifTrue:
[entryPoint = ceImplicitReceiverTrampoline ifTrue:
[| cacheAddress class mixin |
(objectRepresentation
markAndTraceCacheTagLiteral: cacheTag
in: cogMethod
atpc: mcpc asUnsignedInteger) ifTrue:
[codeModified := true]. "cacheTag is selector"
self assert: NumOopsPerIRC = 2.
cacheAddress := self implicitReceiverCacheAddressAt: mcpc.
(class := backEnd unalignedLongAt: cacheAddress) ~= 0
ifTrue:
[(objectRepresentation cacheTagIsMarked: class)
ifTrue:
+ [(mixin := backEnd unalignedLongAt: cacheAddress + objectMemory bytesPerOop) ~= 0 ifTrue:
- [(mixin := backEnd unalignedLongAt: cacheAddress + BytesPerOop) ~= 0 ifTrue:
[objectRepresentation
markAndTraceLiteral: mixin
in: (self cCoerceSimple: cogMethod to: #'CogMethod *')
+ at: (self asAddress: cacheAddress + objectMemory bytesPerOop
+ put: [:val| backEnd unalignedLongAt: cacheAddress + objectMemory bytesPerOop put: val])]]
- at: (self asAddress: cacheAddress + BytesPerOop
- put: [:val| backEnd unalignedLongAt: cacheAddress + BytesPerOop put: val])]]
ifFalse:
[backEnd
unalignedLongAt: cacheAddress put: 0;
+ unalignedLongAt: cacheAddress + objectMemory bytesPerOop put: 0.
- unalignedLongAt: cacheAddress + BytesPerOop put: 0.
codeModified := true]]
ifFalse:
+ [self assert: (backEnd unalignedLongAt: cacheAddress + objectMemory bytesPerOop) = 0]]]]]].
- [self assert: (backEnd unalignedLongAt: cacheAddress + BytesPerOop) = 0]]]]]].
^0 "keep scanning"!
Item was changed:
----- Method: Cogit>>markYoungObjects:pc:method: (in category 'garbage collection') -----
markYoungObjects: annotation pc: mcpc method: cogMethod
"Mark and trace young literals."
<var: #mcpc type: #'char *'>
| literal |
annotation = IsObjectReference ifTrue:
[literal := backEnd literalBeforeFollowingAddress: mcpc asInteger.
objectRepresentation markAndTraceLiteralIfYoung: literal].
(self isSendAnnotation: annotation) ifTrue:
[self offsetCacheTagAndCouldBeObjectAt: mcpc annotation: annotation into:
[:entryPoint :cacheTag :tagCouldBeObj |
tagCouldBeObj ifTrue:
[objectRepresentation markAndTraceLiteralIfYoung: cacheTag].
self cppIf: NewspeakVM ifTrue:
[entryPoint = ceImplicitReceiverTrampoline ifTrue:
[| cacheAddress class mixin |
self assert: NumOopsPerIRC = 2.
cacheAddress := self implicitReceiverCacheAddressAt: mcpc.
class := backEnd unalignedLongAt: cacheAddress.
class ~= 0 ifTrue:
[objectRepresentation inlineCacheTagsMayBeObjects ifTrue:
[objectRepresentation markAndTraceLiteralIfYoung: class].
+ mixin := backEnd unalignedLongAt: cacheAddress + objectMemory bytesPerOop.
- mixin := backEnd unalignedLongAt: cacheAddress + BytesPerOop.
objectRepresentation markAndTraceLiteralIfYoung: mixin]]]]].
^0 "keep scanning"!
Item was changed:
----- Method: Cogit>>remapIfObjectRef:pc:hasYoung: (in category 'garbage collection') -----
remapIfObjectRef: annotation pc: mcpc hasYoung: hasYoungPtr
<var: #mcpc type: #'char *'>
<var: #targetMethod type: #'CogMethod *'>
annotation = IsObjectReference ifTrue:
[| literal mappedLiteral |
literal := backEnd literalBeforeFollowingAddress: mcpc asInteger.
(objectRepresentation couldBeObject: literal) ifTrue:
[mappedLiteral := objectRepresentation remapObject: literal.
literal ~= mappedLiteral ifTrue:
[backEnd storeLiteral: mappedLiteral beforeFollowingAddress: mcpc asInteger.
codeModified := true].
(hasYoungPtr ~= 0
and: [objectMemory isYoung: mappedLiteral]) ifTrue:
[(self cCoerceSimple: hasYoungPtr to: #'sqInt *') at: 0 put: true]]].
(self isSendAnnotation: annotation) ifTrue:
[self offsetCacheTagAndCouldBeObjectAt: mcpc annotation: annotation into:
[:entryPoint :cacheTag :tagCouldBeObj | | mappedCacheTag |
(tagCouldBeObj
and: [objectRepresentation couldBeObject: cacheTag]) ifTrue:
[mappedCacheTag := objectRepresentation remapObject: cacheTag.
cacheTag ~= mappedCacheTag ifTrue:
[backEnd rewriteInlineCacheTag: mappedCacheTag at: mcpc asInteger.
codeModified := true].
(hasYoungPtr ~= 0
and: [objectMemory isYoung: mappedCacheTag]) ifTrue:
[(self cCoerceSimple: hasYoungPtr to: #'sqInt *') at: 0 put: true]].
(self cppIf: NewspeakVM
ifTrue: [entryPoint = ceImplicitReceiverTrampoline]
ifFalse: [false])
ifTrue: "Examine an implicit receiver cache."
[| cacheAddress oop mappedOop |
self assert: NumOopsPerIRC = 2.
cacheAddress := self implicitReceiverCacheAddressAt: mcpc.
(oop := backEnd unalignedLongAt: cacheAddress) ~= 0 ifTrue:
["First look at the classTag entry. This is an inline cache tag and so might not be an object."
(objectRepresentation inlineCacheTagsMayBeObjects
and: [objectRepresentation couldBeObject: oop]) ifTrue:
[mappedOop := objectRepresentation remapOop: oop.
mappedOop ~= oop ifTrue:
[backEnd unalignedLongAt: cacheAddress put: mappedOop].
(hasYoungPtr ~= 0
and: [objectMemory isYoung: mappedOop]) ifTrue:
[(self cCoerceSimple: hasYoungPtr to: #'sqInt *') at: 0 put: true]].
"Second look at the mixin entry. this must be 0 or an object."
+ (oop := backEnd unalignedLongAt: cacheAddress + objectMemory bytesPerOop) ~= 0 ifTrue:
- (oop := backEnd unalignedLongAt: cacheAddress + BytesPerOop) ~= 0 ifTrue:
[mappedOop := objectRepresentation remapOop: oop.
mappedOop ~= oop ifTrue:
+ [backEnd unalignedLongAt: cacheAddress + objectMemory bytesPerOop put: mappedOop].
- [backEnd unalignedLongAt: cacheAddress + BytesPerOop put: mappedOop].
(hasYoungPtr ~= 0
and: [objectMemory isYoung: mappedOop]) ifTrue:
[(self cCoerceSimple: hasYoungPtr to: #'sqInt *') at: 0 put: true]]]]
ifFalse:
[hasYoungPtr ~= 0 ifTrue:
["Since the unlinking routines may rewrite the cacheTag to the send's selector, and
since they don't have the cogMethod to hand and can't add it to youngReferrers,
the method must remain in youngReferrers if the targetMethod's selector is young."
entryPoint > methodZoneBase ifTrue: "It's a linked send."
[self targetMethodAndSendTableFor: entryPoint into:
[:targetMethod :ignored|
(objectMemory isYoung: targetMethod selector) ifTrue:
[(self cCoerceSimple: hasYoungPtr to: #'sqInt *') at: 0 put: true]]]]]]].
^0 "keep scanning"!
Item was changed:
----- Method: Cogit>>simulateEnilopmart:numArgs: (in category 'simulation only') -----
simulateEnilopmart: enilopmartAddress numArgs: n
<doNotGenerate>
"Enter Cog code, popping the class reg and receiver from the stack
and then returning to the address beneath them.
In the actual VM the enilopmart is a function pointer and so senders
of this method end up calling the enilopmart to enter machine code.
In simulation we either need to start simulating execution (if we're in
the interpreter) or return to the simulation (if we're in the run-time
called from machine code. We should also smash the register state
since, being an abnormal entry, no saved registers will be restored."
self assert: (coInterpreter isOnRumpCStack: processor sp).
self assert: ((coInterpreter stackValue: n) between: guardPageSize and: methodZone freeStart - 1).
(printInstructions or: [printRegisters]) ifTrue:
[coInterpreter printExternalHeadFrame].
processor
+ smashRegistersWithValuesFrom: 16r80000000 by: objectMemory wordSize;
- smashRegistersWithValuesFrom: 16r80000000 by: BytesPerWord;
simulateLeafCallOf: enilopmartAddress
nextpc: 16rBADF00D
memory: coInterpreter memory.
"If we're already simulating in the context of machine code then
this will take us back to handleCallSimulationTrap:. Otherwise
start executing machine code in the simulator."
(ReenterMachineCode new returnValue: #continueNoReturn) signal.
self simulateCogCodeAt: enilopmartAddress.
"We should either longjmp back to the interpreter or
stay in machine code so control should not reach here."
self assert: false!
Item was changed:
----- Method: Cogit>>simulatedAddressFor: (in category 'initialization') -----
simulatedAddressFor: anObject
"Answer a simulated address for a block or a symbol. This is an address that
can be called, read or written by generated machine code, and will be mapped
into a Smalltalk message send or block evaluation.
N.B. These addresses are at the top end of the bottom half of the address space
so that they don't have the sign bit set and so will not look like negative numbers."
<doNotGenerate>
^simulatedAddresses
at: anObject
+ ifAbsentPut: [(simulatedAddresses size + 101 * objectMemory wordSize) negated bitAnd: self allButTopBitOfAddressSpaceMask]!
- ifAbsentPut: [(simulatedAddresses size + 101 * BytesPerWord) negated bitAnd: self allButTopBitOfAddressSpaceMask]!
Item was changed:
----- Method: Cogit>>unlinkIfForwardedSend:pc:ignored: (in category 'in-line cacheing') -----
unlinkIfForwardedSend: annotation pc: mcpc ignored: superfluity
<var: #mcpc type: #'char *'>
| entryPoint cacheAddress |
(self isSendAnnotation: annotation) ifTrue:
[entryPoint := backEnd callTargetFromReturnAddress: mcpc asInteger.
entryPoint > methodZoneBase
ifTrue: "It's a linked send, but maybe a super send or linked to an OpenPIC, in which case the cache tag will be a selector...."
[(objectMemory isForwardedClassIndex: (backEnd inlineCacheTagAt: mcpc asInteger)) ifTrue:
[self targetMethodAndSendTableFor: entryPoint into:
[:targetMethod :sendTable|
self unlinkSendAt: mcpc targetMethod: targetMethod sendTable: sendTable]]]
ifFalse:
[self cppIf: NewspeakVM ifTrue:
[entryPoint = ceImplicitReceiverTrampoline ifTrue:
[self assert: NumOopsPerIRC = 2.
cacheAddress := self implicitReceiverCacheAddressAt: mcpc.
((objectMemory isForwardedClassIndex: (backEnd unalignedLongAt: cacheAddress))
+ or: [objectMemory isForwardedClassIndex: (backEnd unalignedLongAt: cacheAddress + objectMemory bytesPerOop)]) ifTrue:
- or: [objectMemory isForwardedClassIndex: (backEnd unalignedLongAt: cacheAddress + BytesPerOop)]) ifTrue:
[self voidImplicitReceiverCacheAt: mcpc]]]]].
^0 "keep scanning"!
Item was changed:
----- Method: Cogit>>voidImplicitReceiverCacheAt: (in category 'newspeak support') -----
voidImplicitReceiverCacheAt: mcpc
"Cached push implicit receiver implementation. If objectRepresentation doesn't support
pinning then caller looks like
mov selector, SendNumArgsReg
call ceImplicitReceiver
br continue
Lclass: .word
Lmixin:: .word
continue:
If objectRepresentation supports pinning then caller looks like
mov Lclass, Arg1Reg
mov selector, SendNumArgsReg
call ceImplicitReceiver
and Lclass: .word; Lmixin: .word is somewhere on the heap."
<option: #NewspeakVM>
| cacheAddress |
self assert: NumOopsPerIRC = 2.
cacheAddress := self implicitReceiverCacheAddressAt: mcpc.
backEnd
unalignedLongAt: cacheAddress put: 0;
+ unalignedLongAt: cacheAddress + objectMemory bytesPerOop put: 0.
- unalignedLongAt: cacheAddress + BytesPerOop put: 0.
objectRepresentation canPinObjects ifFalse:
[codeModified := true]!
Item was changed:
----- Method: FilePlugin>>primitiveFileStdioHandles (in category 'file primitives') -----
primitiveFileStdioHandles
"Answer an Array of file handles for standard in, standard out and standard error,
with nil in entries that are unvailable, e.g. because the platform does not provide
standard error, etc. Fail if there are no standard i/o facilities on the platform or
if the security plugin denies access or if memory runs out."
| fileRecords result validMask |
<export: true>
<var: 'fileRecords' declareC: 'SQFile fileRecords[3]'>
sHFAfn ~= 0 ifTrue:
[(self cCode: ' ((sqInt (*)(void))sHFAfn)()' inSmalltalk: [true]) ifFalse:
[^interpreterProxy primitiveFailFor: PrimErrUnsupported]].
self cCode: '' inSmalltalk: [fileRecords := Array new: 3].
validMask := self sqFileStdioHandlesInto: fileRecords.
validMask = 0 ifTrue:
[^interpreterProxy primitiveFailFor: PrimErrUnsupported].
result := interpreterProxy instantiateClass: interpreterProxy classArray indexableSize: 3.
result = nil ifTrue:
[^interpreterProxy primitiveFailFor: PrimErrNoMemory].
interpreterProxy pushRemappableOop: result.
0 to: 2 do:
[:index|
(validMask bitAnd: (1 << index)) ~= 0 ifTrue:
[result := interpreterProxy instantiateClass: interpreterProxy classByteArray indexableSize: self fileRecordSize.
result = nil ifTrue:
[interpreterProxy popRemappableOop.
^interpreterProxy primitiveFailFor: PrimErrNoMemory].
interpreterProxy storePointer: index ofObject: interpreterProxy topRemappableOop withValue: result.
self
cCode:
[self mem: (interpreterProxy firstIndexableField: result)
cp: (self addressOf: (fileRecords at: index))
y: self fileRecordSize]
inSmalltalk:
[(interpreterProxy firstIndexableField: result)
+ unitSize: interpreterProxy wordSize;
- unitSize: BytesPerWord;
at: 0 put: (fileRecords at: index + 1)]]].
"In the threaded VM ensure the handles are old, so that sqFileReadIntoAt is unaffected
by incremental GCs. See platforms/Cross/plugins/FilePlugin/sqFilePluginBasicPrims.c."
self cppIf: COGMTVM
ifTrue: [interpreterProxy fullGC].
result := interpreterProxy popRemappableOop.
interpreterProxy pop: 1 thenPush: result!
Item was changed:
----- Method: FilePluginSimulator>>fileValueOf: (in category 'simulation') -----
fileValueOf: objectPointer
| index file |
index := (interpreterProxy isIntegerObject: objectPointer)
ifTrue: [interpreterProxy integerValueOf: objectPointer]
ifFalse:
[((interpreterProxy isBytes: objectPointer)
+ and: [(interpreterProxy byteSizeOf: objectPointer) = interpreterProxy wordSize]) ifFalse:
- and: [(interpreterProxy byteSizeOf: objectPointer) = BytesPerWord]) ifFalse:
[interpreterProxy primitiveFail.
^nil].
+ interpreterProxy longAt: objectPointer + interpreterProxy baseHeaderSize].
- interpreterProxy longAt: objectPointer + 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 removed:
- ----- Method: IA32ABIPlugin class>>initialize (in category 'class initialization') -----
- initialize
- BytesPerOop := BytesPerWord!
Item was changed:
----- Method: IA32ABIPlugin>>primAddressField (in category 'primitives-accessing') -----
primAddressField
"Answer the unsigned 32-bit integer comprising the address field (the second 32-bit field)."
"<Alien> primAddressField ^<Integer>
<primitive: 'primAddressField' error: errorCode module: 'IA32ABI'>"
| rcvr value valueOop |
<export: true>
rcvr := interpreterProxy stackValue: 0.
+ value := self longAt: rcvr + interpreterProxy baseHeaderSize + interpreterProxy bytesPerOop.
- value := self longAt: rcvr + BaseHeaderSize + BytesPerOop.
valueOop := interpreterProxy positive32BitIntegerFor: value.
^interpreterProxy methodReturnValue: valueOop!
Item was changed:
----- Method: IA32ABIPlugin>>primAddressFieldPut (in category 'primitives-accessing') -----
primAddressFieldPut
"Store an unsigned integer into the size field (the second 32 bit field; little endian)."
"<Alien> addressFieldPut: value <Integer> ^<Integer>
<primitive: 'primAddressFieldPut' error: errorCode module: 'IA32ABI'>"
| rcvr value valueOop |
<export: true>
valueOop := interpreterProxy stackValue: 0.
rcvr := interpreterProxy stackValue: 1.
value := interpreterProxy positive32BitValueOf: valueOop.
interpreterProxy failed ifTrue:
[^interpreterProxy primitiveFailFor: PrimErrBadArgument].
+ self longAt: rcvr + interpreterProxy baseHeaderSize + interpreterProxy bytesPerOop put: value.
- self longAt: rcvr + BaseHeaderSize + BytesPerOop put: value.
^interpreterProxy methodReturnValue: valueOop!
Item was changed:
----- Method: IA32ABIPlugin>>primSizeField (in category 'primitives-accessing') -----
primSizeField
"Answer the signed 32-bit integer comprising the size field (the first 32-bit field)."
"<Alien> primSizeField ^<Integer>
<primitive: 'primSizeField' error: errorCode module: 'IA32ABI'>"
| rcvr value valueOop |
<export: true>
rcvr := interpreterProxy stackValue: 0.
+ value := (self longAt: rcvr + interpreterProxy baseHeaderSize) signedIntFromLong.
- value := (self longAt: rcvr + BaseHeaderSize) signedIntFromLong.
valueOop := interpreterProxy signed32BitIntegerFor: value.
^interpreterProxy methodReturnValue: valueOop!
Item was changed:
----- Method: IA32ABIPlugin>>primSizeFieldPut (in category 'primitives-accessing') -----
primSizeFieldPut
"Store a signed integer into the size field (the first 32 bit field; little endian)."
"<Alien> sizeFieldPut: value <Integer> ^<Integer>
<primitive: 'primSizeFieldPut' error: errorCode module: 'IA32ABI'>"
| rcvr value valueOop |
<export: true>
valueOop := interpreterProxy stackValue: 0.
rcvr := interpreterProxy stackValue: 1.
value := interpreterProxy signed32BitValueOf: valueOop.
interpreterProxy failed ifTrue:
[^interpreterProxy primitiveFailFor: PrimErrBadArgument].
+ self longAt: rcvr + interpreterProxy baseHeaderSize put: value signedIntToLong.
- self longAt: rcvr + BaseHeaderSize put: value signedIntToLong.
^interpreterProxy methodReturnValue: valueOop!
Item was changed:
----- Method: IA32ABIPlugin>>sizeField: (in category 'private-support') -----
sizeField: rcvr
"Answer the first field of rcvr which is assumed to be an Alien of at least 8 bytes"
<inline: true>
+ ^self longAt: rcvr + interpreterProxy baseHeaderSize!
- ^self longAt: rcvr + BaseHeaderSize!
Item was changed:
----- Method: IA32ABIPlugin>>startOfByteData: (in category 'private-support') -----
startOfByteData: rcvr "<byte indexable oop> ^<Integer>"
"Answer the start of rcvr's data, given that it is not an alien."
<inline: true>
+ ^rcvr + interpreterProxy baseHeaderSize!
- ^rcvr + BaseHeaderSize!
Item was changed:
----- Method: IA32ABIPlugin>>startOfData: (in category 'private-support') -----
startOfData: rcvr "<Alien oop> ^<Integer>"
"Answer the start of rcvr's data. For direct aliens this is the address of
the second field. For indirect and pointer aliens it is what the second field points to."
<inline: true>
^(self sizeField: rcvr) > 0
+ ifTrue: [rcvr + interpreterProxy baseHeaderSize + interpreterProxy bytesPerOop]
+ ifFalse: [self longAt: rcvr + interpreterProxy baseHeaderSize + interpreterProxy bytesPerOop]!
- ifTrue: [rcvr + BaseHeaderSize + BytesPerOop]
- ifFalse: [self longAt: rcvr + BaseHeaderSize + BytesPerOop]!
Item was changed:
----- Method: IA32ABIPlugin>>startOfData:withSize: (in category 'private-support') -----
startOfData: rcvr "<Alien oop>" withSize: sizeField "<Integer> ^<Integer>"
"Answer the start of rcvr's data. For direct aliens this is the address of
the second field. For indirect and pointer aliens it is what the second field points to."
<inline: true>
^sizeField > 0
+ ifTrue: [rcvr + interpreterProxy baseHeaderSize + interpreterProxy bytesPerOop]
+ ifFalse: [self longAt: rcvr + interpreterProxy baseHeaderSize + interpreterProxy bytesPerOop]!
- ifTrue: [rcvr + BaseHeaderSize + BytesPerOop]
- ifFalse: [self longAt: rcvr + BaseHeaderSize + BytesPerOop]!
Item was changed:
----- Method: Interpreter>>activateNewClosureMethod: (in category 'control primitives') -----
activateNewClosureMethod: blockClosure
"Similar to activateNewMethod but for Closure and newMethod."
| theBlockClosure closureMethod newContext methodHeader numCopied where outerContext |
DoAssertionChecks ifTrue:
[self okayOop: blockClosure].
outerContext := self fetchPointer: ClosureOuterContextIndex ofObject: blockClosure.
DoAssertionChecks ifTrue:
[self okayOop: outerContext].
closureMethod := self fetchPointer: MethodIndex ofObject: outerContext.
methodHeader := self methodHeaderOf: closureMethod.
self pushRemappableOop: blockClosure.
newContext := self allocateOrRecycleContext: (methodHeader bitAnd: LargeContextBit). "All for one, and one for all!!"
"allocateOrRecycleContext: may cause a GC; restore blockClosure and refetch outerContext et al"
theBlockClosure := self popRemappableOop.
outerContext := self fetchPointer: ClosureOuterContextIndex ofObject: theBlockClosure.
numCopied := (self numSlotsOf: theBlockClosure) - ClosureFirstCopiedValueIndex.
"Assume: newContext will be recorded as a root if necessary by the
call to newActiveContext: below, so we can use unchecked stores."
+ where := newContext + self baseHeaderSize.
+ self longAt: where + (SenderIndex << self shiftForWord)
- where := newContext + BaseHeaderSize.
- self longAt: where + (SenderIndex << ShiftForWord)
put: activeContext.
+ self longAt: where + (InstructionPointerIndex << self shiftForWord)
- self longAt: where + (InstructionPointerIndex << ShiftForWord)
put: (self fetchPointer: ClosureStartPCIndex ofObject: theBlockClosure).
+ self longAt: where + (StackPointerIndex << self shiftForWord)
- self longAt: where + (StackPointerIndex << ShiftForWord)
put: (self integerObjectOf: argumentCount + numCopied).
+ self longAt: where + (MethodIndex << self shiftForWord)
- self longAt: where + (MethodIndex << ShiftForWord)
put: (self fetchPointer: MethodIndex ofObject: outerContext).
+ self longAt: where + (ClosureIndex << self shiftForWord)
- self longAt: where + (ClosureIndex << ShiftForWord)
put: theBlockClosure.
+ self longAt: where + (ReceiverIndex << self shiftForWord)
- self longAt: where + (ReceiverIndex << ShiftForWord)
put: (self fetchPointer: ReceiverIndex ofObject: outerContext).
"Copy the arguments..."
1 to: argumentCount do:
+ [:i | self longAt: where + ((ReceiverIndex+i) << self shiftForWord)
- [:i | self longAt: where + ((ReceiverIndex+i) << ShiftForWord)
put: (self stackValue: argumentCount-i)].
"Copy the copied values..."
+ where := newContext + self baseHeaderSize + ((ReceiverIndex + 1 + argumentCount) << self shiftForWord).
- where := newContext + BaseHeaderSize + ((ReceiverIndex + 1 + argumentCount) << ShiftForWord).
0 to: numCopied - 1 do:
+ [:i| self longAt: where + (i << self shiftForWord)
- [:i| self longAt: where + (i << ShiftForWord)
put: (self fetchPointer: i + ClosureFirstCopiedValueIndex
ofObject: theBlockClosure)].
"The initial instructions in the block nil-out remaining temps."
self pop: argumentCount + 1.
self newActiveContext: newContext!
Item was changed:
----- Method: Interpreter>>activateNewMethod (in category 'message sending') -----
activateNewMethod
| newContext methodHeader initialIP tempCount nilOop where |
methodHeader := self methodHeaderOf: newMethod.
newContext := self allocateOrRecycleContext: (methodHeader bitAnd: LargeContextBit).
+ initialIP := ((LiteralStart + (self literalCountOfMethodHeader: methodHeader)) * self wordSize) + 1.
- initialIP := ((LiteralStart + (self literalCountOfMethodHeader: methodHeader)) * BytesPerWord) + 1.
tempCount := (methodHeader >> 19) bitAnd: 16r3F.
"Assume: newContext will be recorded as a root if necessary by the
call to newActiveContext: below, so we can use unchecked stores."
+ where := newContext + self baseHeaderSize.
+ self longAt: where + (SenderIndex << self shiftForWord) put: activeContext.
+ self longAt: where + (InstructionPointerIndex << self shiftForWord) put: (self integerObjectOf: initialIP).
+ self longAt: where + (StackPointerIndex << self shiftForWord) put: (self integerObjectOf: tempCount).
+ self longAt: where + (MethodIndex << self shiftForWord) put: newMethod.
+ self longAt: where + (ClosureIndex << self shiftForWord) put: nilObj.
- where := newContext + BaseHeaderSize.
- self longAt: where + (SenderIndex << ShiftForWord) put: activeContext.
- self longAt: where + (InstructionPointerIndex << ShiftForWord) put: (self integerObjectOf: initialIP).
- self longAt: where + (StackPointerIndex << ShiftForWord) put: (self integerObjectOf: tempCount).
- self longAt: where + (MethodIndex << ShiftForWord) put: newMethod.
- self longAt: where + (ClosureIndex << ShiftForWord) put: nilObj.
"Copy the receiver and arguments..."
0 to: argumentCount do:
+ [:i | self longAt: where + ((ReceiverIndex+i) << self shiftForWord) put: (self stackValue: argumentCount-i)].
- [:i | self longAt: where + ((ReceiverIndex+i) << ShiftForWord) put: (self stackValue: argumentCount-i)].
"clear remaining temps to nil in case it has been recycled"
nilOop := nilObj.
argumentCount+1+ReceiverIndex to: tempCount+ReceiverIndex do:
+ [:i | self longAt: where + (i << self shiftForWord) put: nilOop].
- [:i | self longAt: where + (i << ShiftForWord) put: nilOop].
self pop: argumentCount + 1.
reclaimableContextCount := reclaimableContextCount + 1.
self newActiveContext: newContext.!
Item was changed:
----- Method: Interpreter>>arrayValueOf: (in category 'utilities') -----
arrayValueOf: arrayOop
+ "Return the address of first indexable field of resulting array object, or fail if
+ the instance variable does not contain an indexable bytes or words object."
- "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 *'>
+ (self isWordsOrBytes: arrayOop) ifTrue:
+ [^self cCoerceSimple: (self pointerForOop: arrayOop + self baseHeaderSize) to: #'void *'].
+ self primitiveFail!
- <returnTypeC: 'void *'>
- ((self isIntegerObject: arrayOop) not and:
- [self isWordsOrBytes: arrayOop])
- ifTrue: [^ self cCode: '(void *)pointerForOop(arrayOop + BaseHeaderSize)'].
- self primitiveFail.
- !
Item was changed:
----- Method: Interpreter>>assertClassOf:is: (in category 'utilities') -----
assertClassOf: oop is: classOop
"Succeed if oop is an instance of the given class. Fail if the object is an integer."
<inline: true>
- <asmLabel: false>
self success: (self isClassOfNonImm: oop equalTo: classOop)!
Item was changed:
----- Method: Interpreter>>balancedStack:afterPrimitive:withArgs: (in category 'debug support') -----
balancedStack: delta afterPrimitive: primIdx withArgs: nArgs
"Return true if the stack is still balanced after executing primitive primIndex with nArgs args. Delta is 'stackPointer - activeContext' which is a relative measure for the stack pointer (so we don't have to relocate it during the primitive)"
(primIdx >= 81 and:[primIdx <= 88]) ifTrue:[^true].
"81-88 are control primitives after which the stack may look unbalanced"
successFlag ifTrue:[
"Successful prim, stack must have exactly nArgs arguments popped off"
+ ^(stackPointer - activeContext + (nArgs * self wordSize)) = delta
- ^(stackPointer - activeContext + (nArgs * BytesPerWord)) = delta
].
"Failed prim must leave stack intact"
^(stackPointer - activeContext) = delta
!
Item was changed:
----- Method: Interpreter>>byteSwapByteObjectsFrom:to: (in category 'image save/restore') -----
byteSwapByteObjectsFrom: startOop to: stopAddr
"Byte-swap the words of all bytes objects in a range of the
image, including Strings, ByteArrays, and CompiledMethods.
This returns these objects to their original byte ordering
after blindly byte-swapping the entire image. For compiled
methods, byte-swap only their bytecodes part."
| oop fmt wordAddr methodHeader |
oop := startOop.
[self oop: oop isLessThan: stopAddr]
whileTrue: [(self isFreeObject: oop)
ifFalse: [fmt := self formatOf: oop.
fmt >= 8
ifTrue: ["oop contains bytes"
+ wordAddr := oop + self baseHeaderSize.
- wordAddr := oop + BaseHeaderSize.
fmt >= 12
ifTrue: ["compiled method; start after methodHeader and literals"
+ methodHeader := self longAt: oop + self baseHeaderSize.
+ wordAddr := wordAddr + self wordSize + ((methodHeader >> 10 bitAnd: 255) * self wordSize)].
- methodHeader := self longAt: oop + BaseHeaderSize.
- wordAddr := wordAddr + BytesPerWord + ((methodHeader >> 10 bitAnd: 255) * BytesPerWord)].
self reverseBytesFrom: wordAddr to: oop + (self sizeBitsOf: oop)].
+ (fmt = 6 and: [self wordSize = 8])
- (fmt = 6 and: [BytesPerWord = 8])
ifTrue: ["Object contains 32-bit half-words packed into 64-bit machine words."
+ wordAddr := oop + self baseHeaderSize.
- wordAddr := oop + BaseHeaderSize.
self reverseWordsFrom: wordAddr to: oop + (self sizeBitsOf: oop)]].
oop := self objectAfter: oop]!
Item was changed:
----- Method: Interpreter>>closureNumArgs:instructionPointer:numCopiedValues: (in category 'control primitives') -----
closureNumArgs: numArgs instructionPointer: initialIP numCopiedValues: numCopied
| newClosure |
<inline: true>
newClosure := self
instantiateSmallClass: (self splObj: ClassBlockClosure)
+ sizeInBytes: (self wordSize * (ClosureFirstCopiedValueIndex + numCopied)) + self baseHeaderSize.
- sizeInBytes: (BytesPerWord * (ClosureFirstCopiedValueIndex + numCopied)) + BaseHeaderSize.
"Assume: have just allocated a new closure; it must be young. Thus, can use unchecked stores."
self storePointerUnchecked: ClosureStartPCIndex ofObject: newClosure withValue: (self integerObjectOf: initialIP).
self storePointerUnchecked: ClosureNumArgsIndex ofObject: newClosure withValue: (self integerObjectOf: numArgs).
"It is up to the caller to store the outer context and copiedValues."
^newClosure!
Item was changed:
----- Method: Interpreter>>createActualMessageTo: (in category 'message sending') -----
createActualMessageTo: aClass
"Bundle up the selector, arguments and lookupClass into a Message object.
In the process it pops the arguments off the stack, and pushes the message object.
This can then be presented as the argument of e.g. #doesNotUnderstand:.
ikp 11/20/1999 03:59 -- added hook for external runtime compilers."
"remap lookupClass in case GC happens during allocation"
| argumentArray message lookupClass |
<inline: false> "This is a useful break-point"
self pushRemappableOop: aClass.
argumentArray := self instantiateClass: (self splObj: ClassArray) indexableSize: argumentCount.
"remap argumentArray in case GC happens during allocation"
self pushRemappableOop: argumentArray.
message := self instantiateClass: (self splObj: ClassMessage) indexableSize: 0.
argumentArray := self popRemappableOop.
lookupClass := self popRemappableOop.
self beRootIfOld: argumentArray.
compilerInitialized
ifTrue: [self compilerCreateActualMessage: message storingArgs: argumentArray]
+ ifFalse: [self transfer: argumentCount from: stackPointer - (argumentCount - 1 * self wordSize) to: argumentArray + self baseHeaderSize.
- ifFalse: [self transfer: argumentCount from: stackPointer - (argumentCount - 1 * BytesPerWord) to: argumentArray + BaseHeaderSize.
self pop: argumentCount thenPush: message].
argumentCount := 1.
self storePointer: MessageSelectorIndex ofObject: message withValue: messageSelector.
self storePointer: MessageArgumentsIndex ofObject: message withValue: argumentArray.
+ (self lastPointerOf: message) >= (MessageLookupClassIndex * self wordSize + self baseHeaderSize)
- (self lastPointerOf: message) >= (MessageLookupClassIndex * BytesPerWord + BaseHeaderSize)
ifTrue: ["Only store lookupClass if message has 3 fields (old images don't)"
self storePointer: MessageLookupClassIndex ofObject: message withValue: lookupClass]!
Item was changed:
----- Method: Interpreter>>displayBitsOf:Left:Top:Right:Bottom: (in category 'I/O primitives') -----
displayBitsOf: aForm Left: l Top: t Right: r Bottom: b
"Repaint the portion of the Smalltalk screen bounded by the affected rectangle. Used to synchronize the screen after a Bitblt to the Smalltalk Display object."
| displayObj dispBits w h dispBitsIndex d left right top bottom surfaceHandle |
displayObj := self splObj: TheDisplay.
aForm = displayObj ifFalse: [^ nil].
self success: ((self isPointers: displayObj) and: [(self lengthOf: displayObj) >= 4]).
successFlag ifTrue: [
dispBits := self fetchPointer: 0 ofObject: displayObj.
w := self fetchInteger: 1 ofObject: displayObj.
h := self fetchInteger: 2 ofObject: displayObj.
d := self fetchInteger: 3 ofObject: displayObj.
].
l < 0 ifTrue:[left := 0] ifFalse: [left := l].
r > w ifTrue: [right := w] ifFalse: [right := r].
t < 0 ifTrue: [top := 0] ifFalse: [top := t].
b > h ifTrue: [bottom := h] ifFalse: [bottom := b].
((left <= right) and: [top <= bottom]) ifFalse: [^nil].
successFlag ifTrue: [
(self isIntegerObject: dispBits) ifTrue: [
surfaceHandle := self integerValueOf: dispBits.
showSurfaceFn = 0 ifTrue: [
showSurfaceFn := self ioLoadFunction: 'ioShowSurface' From: 'SurfacePlugin'.
showSurfaceFn = 0 ifTrue: [^self success: false]].
self cCode:'((sqInt (*)(sqInt, sqInt, sqInt, sqInt, sqInt))showSurfaceFn)(surfaceHandle, left, top, right-left, bottom-top)'.
] ifFalse: [
+ dispBitsIndex := dispBits + self baseHeaderSize. "index in memory byte array"
- dispBitsIndex := dispBits + BaseHeaderSize. "index in memory byte array"
self cCode: 'ioShowDisplay(dispBitsIndex, w, h, d, left, right, top, bottom)'
inSmalltalk: [self showDisplayBits: dispBitsIndex
w: w h: h d: d
left: left right: right top: top bottom: bottom]
].
].!
Item was changed:
----- Method: Interpreter>>fetchContextRegisters: (in category 'contexts') -----
fetchContextRegisters: activeCntx
"Note: internalFetchContextRegisters: should track changes to this method."
| tmp |
<inline: true>
tmp := self fetchPointer: MethodIndex ofObject: activeCntx.
(self isIntegerObject: tmp)
ifTrue: ["if the MethodIndex field is an integer, activeCntx is a block context"
tmp := self fetchPointer: HomeIndex ofObject: activeCntx.
(self oop: tmp isLessThan: youngStart) ifTrue: [self beRootIfOld: tmp]]
ifFalse: ["otherwise, it is a method context and is its own home context "
tmp := activeCntx].
theHomeContext := tmp.
receiver := self fetchPointer: ReceiverIndex ofObject: tmp.
method := self fetchPointer: MethodIndex ofObject: tmp.
"the instruction pointer is a pointer variable equal to
method oop + ip + BaseHeaderSize
-1 for 0-based addressing of fetchByte
-1 because it gets incremented BEFORE fetching currentByte "
tmp := self quickFetchInteger: InstructionPointerIndex ofObject: activeCntx.
+ instructionPointer := method + tmp + self baseHeaderSize - 2.
- instructionPointer := method + tmp + BaseHeaderSize - 2.
"the stack pointer is a pointer variable also..."
tmp := self quickFetchInteger: StackPointerIndex ofObject: activeCntx.
+ stackPointer := activeCntx + self baseHeaderSize + (TempFrameStart + tmp - 1 * self wordSize)!
- stackPointer := activeCntx + BaseHeaderSize + (TempFrameStart + tmp - 1 * BytesPerWord)!
Item was changed:
----- Method: Interpreter>>fetchIntegerOrTruncFloat:ofObject: (in category 'utilities') -----
fetchIntegerOrTruncFloat: fieldIndex ofObject: objectPointer
"Return the integer value of the given field of the given object. If the field contains a Float, truncate it and return its integral part. Fail if the given field does not contain a small integer or Float, or if the truncated Float is out of the range of small integers."
"Note: May be called by translated primitive code."
| intOrFloat floatVal frac trunc |
<inline: false>
<var: #floatVal type: 'double '>
<var: #frac type: 'double '>
<var: #trunc type: 'double '>
intOrFloat := self fetchPointer: fieldIndex ofObject: objectPointer.
(self isIntegerObject: intOrFloat) ifTrue: [^ self integerValueOf: intOrFloat].
self assertClassOf: intOrFloat is: (self splObj: ClassFloat).
successFlag ifTrue: [
self cCode: '' inSmalltalk: [floatVal := Float new: 2].
+ self fetchFloatAt: intOrFloat + self baseHeaderSize into: floatVal.
- self fetchFloatAt: intOrFloat + BaseHeaderSize into: floatVal.
self cCode: 'frac = modf(floatVal, &trunc)'.
"the following range check is for C ints, with range -2^31..2^31-1"
self flag: #Dan. "The ranges are INCORRECT if SmallIntegers are wider than 31 bits."
self cCode: 'success((-2147483648.0 <= trunc) && (trunc <= 2147483647.0))'.].
successFlag
ifTrue: [^ self cCode: '((sqInt) trunc)' inSmalltalk: [floatVal truncated]]
ifFalse: [^ 0].
!
Item was changed:
----- Method: Interpreter>>floatObjectOf: (in category 'object format') -----
floatObjectOf: aFloat
| newFloatObj |
<inline: false>
<var: #aFloat type: 'double '>
self flag: #Dan.
+ newFloatObj := self instantiateSmallClass: (self splObj: ClassFloat) sizeInBytes: 8+self baseHeaderSize.
+ self storeFloatAt: newFloatObj + self baseHeaderSize from: aFloat.
- newFloatObj := self instantiateSmallClass: (self splObj: ClassFloat) sizeInBytes: 8+BaseHeaderSize.
- self storeFloatAt: newFloatObj + BaseHeaderSize from: aFloat.
^ newFloatObj.
!
Item was changed:
----- Method: Interpreter>>floatValueOf: (in category 'utilities') -----
floatValueOf: oop
"Answer the C double precision floating point value of the argument,
or fail if it is not a Float, and answer 0.
Note: May be called by translated primitive code."
| isFloat result |
<returnTypeC: #double>
<var: #result type: #double>
isFloat := self isInstanceOfClassFloat: oop.
isFloat ifTrue:
[self cCode: '' inSmalltalk: [result := Float new: 2].
+ self fetchFloatAt: oop + self baseHeaderSize into: result.
- self fetchFloatAt: oop + BaseHeaderSize into: result.
^result].
self primitiveFail.
^0.0!
Item was changed:
----- Method: Interpreter>>imageFormatCompatibilityVersion (in category 'image save/restore') -----
imageFormatCompatibilityVersion
"This VM is backward-compatible with the immediately preceeding non-closure version."
+ self wordSize == 4
- BytesPerWord == 4
ifTrue: [^6502]
ifFalse: [^68000]!
Item was changed:
----- Method: Interpreter>>imageFormatVersion (in category 'image save/restore') -----
imageFormatVersion
"Return a magic constant that changes when the image format changes. Since the image reading code uses this to detect byte ordering, one must avoid version numbers that are invariant under byte reversal."
+ self wordSize == 4
- BytesPerWord == 4
ifTrue: [^6504]
ifFalse: [^68002]!
Item was added:
+ ----- Method: Interpreter>>initializeContextIndices (in category 'as yet unclassified') -----
+ initializeContextIndices
+ "Class MethodContext"
+ | contextFixedSizePlusHeader |
+ SenderIndex := 0.
+ InstructionPointerIndex := 1.
+ StackPointerIndex := 2.
+ MethodIndex := 3.
+ ClosureIndex := 4. "N.B. Called receiverMap in the image."
+ ReceiverIndex := 5.
+ TempFrameStart := 6. "Note this is in two places!!"
+
+ "Class BlockContext"
+ CallerIndex := 0.
+ BlockArgumentCountIndex := 3.
+ InitialIPIndex := 4.
+ HomeIndex := 5.
+
+ "Class BlockClosure"
+ ClosureOuterContextIndex := 0.
+ ClosureStartPCIndex := 1.
+ ClosureNumArgsIndex := 2.
+ ClosureFirstCopiedValueIndex := 3.
+
+ CtxtTempFrameStart := 6. "Copy of TempFrameStart in Interp"
+ contextFixedSizePlusHeader := CtxtTempFrameStart + 1.
+ SmallContextSize := contextFixedSizePlusHeader + 16 * self wordSize. "16 indexable fields"
+ "Large contexts have 56 indexable fileds. Max with single header word."
+ "However note that in 64 bits, for now, large contexts have 3-word headers"
+ LargeContextSize := contextFixedSizePlusHeader + 56 * self wordSize!
Item was changed:
----- Method: Interpreter>>internalActivateNewMethod (in category 'message sending') -----
internalActivateNewMethod
| methodHeader newContext tempCount argCount2 needsLarge where |
<inline: true>
methodHeader := self methodHeaderOf: newMethod.
needsLarge := methodHeader bitAnd: LargeContextBit.
(needsLarge = 0 and: [freeContexts ~= NilContext])
ifTrue: [newContext := freeContexts.
freeContexts := self fetchPointer: 0 ofObject: newContext]
ifFalse: ["Slower call for large contexts or empty free list"
self externalizeIPandSP.
newContext := self allocateOrRecycleContext: needsLarge.
self internalizeIPandSP].
tempCount := (methodHeader >> 19) bitAnd: 16r3F.
"Assume: newContext will be recorded as a root if necessary by the
call to newActiveContext: below, so we can use unchecked stores."
+ where := newContext + self baseHeaderSize.
+ self longAt: where + (SenderIndex << self shiftForWord) put: activeContext.
+ self longAt: where + (InstructionPointerIndex << self shiftForWord)
+ put: (self integerObjectOf: (((LiteralStart + (self literalCountOfMethodHeader: methodHeader)) * self wordSize) + 1)).
+ self longAt: where + (StackPointerIndex << self shiftForWord) put: (self integerObjectOf: tempCount).
+ self longAt: where + (MethodIndex << self shiftForWord) put: newMethod.
+ self longAt: where + (ClosureIndex << self shiftForWord) put: nilObj.
- where := newContext + BaseHeaderSize.
- self longAt: where + (SenderIndex << ShiftForWord) put: activeContext.
- self longAt: where + (InstructionPointerIndex << ShiftForWord)
- put: (self integerObjectOf: (((LiteralStart + (self literalCountOfMethodHeader: methodHeader)) * BytesPerWord) + 1)).
- self longAt: where + (StackPointerIndex << ShiftForWord) put: (self integerObjectOf: tempCount).
- self longAt: where + (MethodIndex << ShiftForWord) put: newMethod.
- self longAt: where + (ClosureIndex << ShiftForWord) put: nilObj.
"Copy the receiver and arguments..."
argCount2 := argumentCount.
0 to: argCount2 do:
+ [:i | self longAt: where + ((ReceiverIndex+i) << self shiftForWord) put: (self internalStackValue: argCount2-i)].
- [:i | self longAt: where + ((ReceiverIndex+i) << ShiftForWord) put: (self internalStackValue: argCount2-i)].
"clear remaining temps to nil in case it has been recycled"
methodHeader := nilObj. "methodHeader here used just as faster (register?) temp"
argCount2+1+ReceiverIndex to: tempCount+ReceiverIndex do:
+ [:i | self longAt: where + (i << self shiftForWord) put: methodHeader].
- [:i | self longAt: where + (i << ShiftForWord) put: methodHeader].
self internalPop: argCount2 + 1.
reclaimableContextCount := reclaimableContextCount + 1.
self internalNewActiveContext: newContext.
!
Item was changed:
----- Method: Interpreter>>internalFetchContextRegisters: (in category 'contexts') -----
internalFetchContextRegisters: activeCntx
"Inlined into return bytecodes. The only difference between this method and fetchContextRegisters: is that this method sets the local IP and SP."
| tmp |
<inline: true>
tmp := self fetchPointer: MethodIndex ofObject: activeCntx.
(self isIntegerObject: tmp) ifTrue: [
"if the MethodIndex field is an integer, activeCntx is a block context"
tmp := self fetchPointer: HomeIndex ofObject: activeCntx.
(self oop: tmp isLessThan: youngStart) ifTrue: [ self beRootIfOld: tmp ].
] ifFalse: [
"otherwise, it is a method context and is its own home context"
tmp := activeCntx.
].
localHomeContext := tmp.
receiver := self fetchPointer: ReceiverIndex ofObject: tmp.
method := self fetchPointer: MethodIndex ofObject: tmp.
"the instruction pointer is a pointer variable equal to
method oop + ip + BaseHeaderSize
-1 for 0-based addressing of fetchByte
-1 because it gets incremented BEFORE fetching currentByte"
tmp := self quickFetchInteger: InstructionPointerIndex ofObject: activeCntx.
+ localIP := self pointerForOop: method + tmp + self baseHeaderSize - 2.
- localIP := self pointerForOop: method + tmp + BaseHeaderSize - 2.
"the stack pointer is a pointer variable also..."
tmp := self quickFetchInteger: StackPointerIndex ofObject: activeCntx.
+ localSP := self pointerForOop: activeCntx + self baseHeaderSize + ((TempFrameStart + tmp - 1) * self wordSize)!
- localSP := self pointerForOop: activeCntx + BaseHeaderSize + ((TempFrameStart + tmp - 1) * BytesPerWord)!
Item was changed:
----- Method: Interpreter>>internalPop: (in category 'contexts') -----
internalPop: nItems
+ localSP := localSP - (nItems * self wordSize).!
- localSP := localSP - (nItems * BytesPerWord).!
Item was changed:
----- Method: Interpreter>>internalPop:thenPush: (in category 'contexts') -----
internalPop: nItems thenPush: oop
+ self longAtPointer: (localSP := localSP - ((nItems - 1) * self wordSize)) put: oop.
- self longAtPointer: (localSP := localSP - ((nItems - 1) * BytesPerWord)) put: oop.
!
Item was changed:
----- Method: Interpreter>>internalPush: (in category 'contexts') -----
internalPush: object
+ self longAtPointer: (localSP := localSP + self wordSize) put: object.!
- self longAtPointer: (localSP := localSP + BytesPerWord) put: object.!
Item was changed:
----- Method: Interpreter>>internalQuickCheckForInterrupts (in category 'process primitive support') -----
internalQuickCheckForInterrupts
"Internal version of quickCheckForInterrupts for use within jumps."
<inline: true>
<asmLabel: true>
statQuickCheckForEvents := statQuickCheckForEvents + 1.
((interruptCheckCounter := interruptCheckCounter - 1) <= 0) ifTrue: [
self externalizeIPandSP.
self checkForInterrupts.
self browserPluginReturnIfNeeded.
+ self internalizeIPandSP]!
- self internalizeIPandSP].
- !
Item was changed:
----- Method: Interpreter>>internalStackValue: (in category 'contexts') -----
internalStackValue: offset
+ ^ self longAtPointer: localSP - (offset * self wordSize)!
- ^ self longAtPointer: localSP - (offset * BytesPerWord)!
Item was changed:
----- Method: Interpreter>>internalStoreContextRegisters: (in category 'contexts') -----
internalStoreContextRegisters: activeCntx
"The only difference between this method and fetchContextRegisters: is that this method stores from the local IP and SP."
"InstructionPointer is a pointer variable equal to
method oop + ip + BaseHeaderSize
-1 for 0-based addressing of fetchByte
-1 because it gets incremented BEFORE fetching currentByte"
<inline: true>
self storePointerUnchecked: InstructionPointerIndex ofObject: activeCntx
withValue: (self integerObjectOf:
+ ((self oopForPointer: localIP) + 2 - (method + self baseHeaderSize))).
- ((self oopForPointer: localIP) + 2 - (method + BaseHeaderSize))).
self storePointerUnchecked: StackPointerIndex ofObject: activeCntx
withValue: (self integerObjectOf:
+ ((((self oopForPointer: localSP) - (activeCntx + self baseHeaderSize)) >> self shiftForWord) - TempFrameStart + 1)).
- ((((self oopForPointer: localSP) - (activeCntx + BaseHeaderSize)) >> ShiftForWord) - TempFrameStart + 1)).
!
Item was changed:
----- Method: Interpreter>>justActivateNewMethod (in category 'callback support') -----
justActivateNewMethod
"Activate the new method but *do not* copy receiver or arguments from activeContext."
| methodHeader initialIP newContext tempCount needsLarge where |
<inline: true>
methodHeader := self methodHeaderOf: newMethod.
needsLarge := methodHeader bitAnd: LargeContextBit.
(needsLarge = 0 and: [freeContexts ~= NilContext])
ifTrue: [newContext := freeContexts.
freeContexts := self fetchPointer: 0 ofObject: newContext]
ifFalse: ["Slower call for large contexts or empty free list"
newContext := self allocateOrRecycleContext: needsLarge].
+ initialIP := ((LiteralStart + (self literalCountOfMethodHeader: methodHeader)) * self wordSize) + 1.
- initialIP := ((LiteralStart + (self literalCountOfMethodHeader: methodHeader)) * BytesPerWord) + 1.
tempCount := (methodHeader >> 19) bitAnd: 16r3F.
"Assume: newContext will be recorded as a root if necessary by the
call to newActiveContext: below, so we can use unchecked stores."
+ where := newContext + self baseHeaderSize.
+ self longAt: where + (SenderIndex << self shiftForWord) put: activeContext.
+ self longAt: where + (InstructionPointerIndex << self shiftForWord) put: (self integerObjectOf: initialIP).
+ self longAt: where + (StackPointerIndex << self shiftForWord) put: (self integerObjectOf: tempCount).
+ self longAt: where + (MethodIndex << self shiftForWord) put: newMethod.
- where := newContext + BaseHeaderSize.
- self longAt: where + (SenderIndex << ShiftForWord) put: activeContext.
- self longAt: where + (InstructionPointerIndex << ShiftForWord) put: (self integerObjectOf: initialIP).
- self longAt: where + (StackPointerIndex << ShiftForWord) put: (self integerObjectOf: tempCount).
- self longAt: where + (MethodIndex << ShiftForWord) put: newMethod.
"Set the receiver..."
+ self longAt: where + (ReceiverIndex << self shiftForWord) put: receiver.
- self longAt: where + (ReceiverIndex << ShiftForWord) put: receiver.
"clear all args and temps to nil in case it has been recycled"
needsLarge := nilObj. "needsLarge here used just as faster (register?) temp"
ReceiverIndex + 1 to: tempCount + ReceiverIndex do:
+ [:i | self longAt: where + (i << self shiftForWord) put: needsLarge].
- [:i | self longAt: where + (i << ShiftForWord) put: needsLarge].
reclaimableContextCount := reclaimableContextCount + 1.
activeContext := newContext.
(self oop: newContext isLessThan: youngStart) ifTrue:
[self beRootIfOld: newContext].
self fetchContextRegisters: activeContext!
Item was changed:
----- Method: Interpreter>>loadFloatOrIntFrom: (in category 'utilities') -----
loadFloatOrIntFrom: floatOrInt
"If floatOrInt is an integer, then convert it to a C double float and return it.
If it is a Float, then load its value and return it.
Otherwise fail -- ie return with primErrorCode non-zero."
<inline: true>
- <asmLabel: false>
<returnTypeC: #double>
(self isIntegerObject: floatOrInt) ifTrue:
[^(self integerValueOf: floatOrInt) asFloat].
^self floatValueOf: floatOrInt!
Item was changed:
----- Method: Interpreter>>makePointwithxValue:yValue: (in category 'utilities') -----
makePointwithxValue: xValue yValue: yValue
"make a Point xValue@yValue.
We know both will be integers so no value nor root checking is needed"
| pointResult |
+ pointResult := self instantiateSmallClass: (self splObj: ClassPoint) sizeInBytes: 3*self wordSize.
- pointResult := self instantiateSmallClass: (self splObj: ClassPoint) sizeInBytes: 3*BytesPerWord.
self storePointerUnchecked: XIndex ofObject: pointResult withValue: (self integerObjectOf: xValue).
self storePointerUnchecked: YIndex ofObject: pointResult withValue: (self integerObjectOf: yValue).
^ pointResult!
Item was changed:
----- Method: Interpreter>>pop: (in category 'contexts') -----
pop: nItems
"Note: May be called by translated primitive code."
+ stackPointer := stackPointer - (nItems*self wordSize).
- stackPointer := stackPointer - (nItems*BytesPerWord).
^nil!
Item was changed:
----- Method: Interpreter>>pop:thenPush: (in category 'contexts') -----
pop: nItems thenPush: oop
| sp |
+ self longAt: (sp := stackPointer - ((nItems - 1) * self wordSize)) put: oop.
- self longAt: (sp := stackPointer - ((nItems - 1) * BytesPerWord)) put: oop.
stackPointer := sp.
!
Item was changed:
----- Method: Interpreter>>pop:thenPushBool: (in category 'contexts') -----
pop: nItems thenPushBool: trueOrFalse
"A few places pop a few items off the stack and then push a boolean. Make it convenient"
| sp |
+ self longAt: (sp := stackPointer - ((nItems - 1) * self wordSize))
- self longAt: (sp := stackPointer - ((nItems - 1) * BytesPerWord))
put:(trueOrFalse ifTrue: [trueObj] ifFalse: [falseObj]).
stackPointer := sp!
Item was changed:
----- Method: Interpreter>>pop:thenPushInteger: (in category 'contexts') -----
pop: nItems thenPushInteger: integerVal
"lots of places pop a few items off the stack and then push an integer. MAke it convenient"
| sp |
+ self longAt: (sp := stackPointer - ((nItems - 1) * self wordSize)) put:(self integerObjectOf: integerVal).
- self longAt: (sp := stackPointer - ((nItems - 1) * BytesPerWord)) put:(self integerObjectOf: integerVal).
stackPointer := sp.
!
Item was changed:
----- Method: Interpreter>>popStack (in category 'contexts') -----
popStack
| top |
top := self longAt: stackPointer.
+ stackPointer := stackPointer - self wordSize.
- stackPointer := stackPointer - BytesPerWord.
^ top!
Item was changed:
----- Method: Interpreter>>positive32BitIntegerFor: (in category 'primitive support') -----
positive32BitIntegerFor: integerValue
| newLargeInteger |
"Note - integerValue is interpreted as POSITIVE, eg, as the result of
Bitmap>at:, or integer>bitAnd:."
integerValue >= 0
ifTrue: [(self isIntegerValue: integerValue)
ifTrue: [^ self integerObjectOf: integerValue]].
+ self wordSize = 4
- BytesPerWord = 4
ifTrue: ["Faster instantiateSmallClass: currently only works with integral word size."
newLargeInteger := self instantiateSmallClass: (self splObj: ClassLargePositiveInteger)
+ sizeInBytes: self baseHeaderSize + 4]
- sizeInBytes: BaseHeaderSize + 4]
ifFalse: ["Cant use instantiateSmallClass: due to integral word requirement."
newLargeInteger := self instantiateClass: (self splObj: ClassLargePositiveInteger)
indexableSize: 4].
self storeByte: 3 ofObject: newLargeInteger withValue: ((integerValue >> 24) bitAnd: 16rFF).
self storeByte: 2 ofObject: newLargeInteger withValue: ((integerValue >> 16) bitAnd: 16rFF).
self storeByte: 1 ofObject: newLargeInteger withValue: ((integerValue >> 8) bitAnd: 16rFF).
self storeByte: 0 ofObject: newLargeInteger withValue: (integerValue bitAnd: 16rFF).
^ newLargeInteger!
Item was changed:
----- Method: Interpreter>>primitiveBeCursor (in category 'I/O primitives') -----
primitiveBeCursor
"Set the cursor to the given shape. The Mac only supports 16x16 pixel cursors. Cursor offsets are handled by Smalltalk."
| cursorObj maskBitsIndex maskObj bitsObj extentX extentY depth offsetObj offsetX offsetY cursorBitsIndex ourCursor |
argumentCount = 0 ifTrue: [
cursorObj := self stackTop.
maskBitsIndex := nil].
argumentCount = 1 ifTrue: [
cursorObj := self stackValue: 1.
maskObj := self stackTop].
self success: (argumentCount < 2).
self success: ((self isPointers: cursorObj) and: [(self lengthOf: cursorObj) >= 5]).
successFlag ifTrue: [
bitsObj := self fetchPointer: 0 ofObject: cursorObj.
extentX := self fetchInteger: 1 ofObject: cursorObj.
extentY := self fetchInteger: 2 ofObject: cursorObj.
depth := self fetchInteger: 3 ofObject: cursorObj.
offsetObj := self fetchPointer: 4 ofObject: cursorObj].
self success: ((self isPointers: offsetObj) and: [(self lengthOf: offsetObj) >= 2]).
successFlag ifTrue: [
offsetX := self fetchInteger: 0 ofObject: offsetObj.
offsetY := self fetchInteger: 1 ofObject: offsetObj.
(argumentCount = 0 and: [depth = 32])
ifTrue: [
"Support arbitrary-sized 32 bit ARGB forms --bf 3/1/2007 23:51"
self success: ((extentX > 0) and: [extentY > 0]).
self success: ((offsetX >= (extentX * -1)) and: [offsetX <= 0]).
self success: ((offsetY >= (extentY * -1)) and: [offsetY <= 0]).
+ cursorBitsIndex := bitsObj + self baseHeaderSize.
- cursorBitsIndex := bitsObj + BaseHeaderSize.
self success: ((self isWords: bitsObj) and: [(self lengthOf: bitsObj) = (extentX * extentY)]).
self cCode: '' inSmalltalk:
[ourCursor := Cursor
extent: extentX @ extentY
depth: 32
fromArray: ((1 to: extentX * extentY) collect: [:i |
self fetchLong32: i-1 ofObject: bitsObj])
offset: offsetX @ offsetY]]
ifFalse: [
self success: ((extentX = 16) and: [extentY = 16 and: [depth = 1]]).
self success: ((offsetX >= -16) and: [offsetX <= 0]).
self success: ((offsetY >= -16) and: [offsetY <= 0]).
self success: ((self isWords: bitsObj) and: [(self lengthOf: bitsObj) = 16]).
+ cursorBitsIndex := bitsObj + self baseHeaderSize.
- cursorBitsIndex := bitsObj + BaseHeaderSize.
self cCode: '' inSmalltalk:
[ourCursor := Cursor
extent: extentX @ extentY
fromArray: ((1 to: 16) collect: [:i |
((self fetchLong32: i-1 ofObject: bitsObj) >> 16) bitAnd: 16rFFFF])
offset: offsetX @ offsetY]]].
argumentCount = 1 ifTrue: [
self success: ((self isPointers: maskObj) and: [(self lengthOf: maskObj) >= 5]).
successFlag ifTrue: [
bitsObj := self fetchPointer: 0 ofObject: maskObj.
extentX := self fetchInteger: 1 ofObject: maskObj.
extentY := self fetchInteger: 2 ofObject: maskObj.
depth := self fetchInteger: 3 ofObject: maskObj].
successFlag ifTrue: [
self success: ((extentX = 16) and: [extentY = 16 and: [depth = 1]]).
self success: ((self isWords: bitsObj) and: [(self lengthOf: bitsObj) = 16]).
+ maskBitsIndex := bitsObj + self baseHeaderSize]].
- maskBitsIndex := bitsObj + BaseHeaderSize]].
successFlag ifTrue: [
argumentCount = 0
ifTrue: [
depth = 32
ifTrue: [(self cCode: 'ioSetCursorARGB(cursorBitsIndex, extentX, extentY, offsetX, offsetY)'
inSmalltalk: [ourCursor show. Cursor currentCursor == ourCursor])
ifFalse: [^self success: false. ]]
ifFalse: [self cCode: 'ioSetCursor(cursorBitsIndex, offsetX, offsetY)'
inSmalltalk: [ourCursor show]]]
ifFalse: [self cCode: 'ioSetCursorWithMask(cursorBitsIndex, maskBitsIndex, offsetX, offsetY)'
inSmalltalk: [cursorBitsIndex == maskBitsIndex. "placate compiler"
ourCursor show]].
self pop: argumentCount]!
Item was changed:
----- Method: Interpreter>>primitiveBlockCopy (in category 'control primitives') -----
primitiveBlockCopy
| context methodContext contextSize newContext initialIP |
context := self stackValue: 1.
(self isIntegerObject: (self fetchPointer: MethodIndex ofObject: context))
ifTrue: ["context is a block; get the context of its enclosing method"
methodContext := self fetchPointer: HomeIndex ofObject: context]
ifFalse: [methodContext := context].
contextSize := self sizeBitsOf: methodContext. "in bytes, including header"
context := nil. "context is no longer needed and is not preserved across allocation"
"remap methodContext in case GC happens during allocation"
self pushRemappableOop: methodContext.
newContext := self instantiateContext: (self splObj: ClassBlockContext) sizeInBytes: contextSize.
methodContext := self popRemappableOop.
+ initialIP := self integerObjectOf: (instructionPointer+1+3) - (method+self baseHeaderSize).
- initialIP := self integerObjectOf: (instructionPointer+1+3) - (method+BaseHeaderSize).
"Was instructionPointer + 3, but now it's greater by 1 due to preIncrement"
"Assume: have just allocated a new context; it must be young.
Thus, can use uncheck stores. See the comment in fetchContextRegisters."
self storePointerUnchecked: InitialIPIndex ofObject: newContext withValue: initialIP.
self storePointerUnchecked: InstructionPointerIndex ofObject: newContext withValue: initialIP.
self storeStackPointerValue: 0 inContext: newContext.
self storePointerUnchecked: BlockArgumentCountIndex ofObject: newContext withValue: (self stackValue: 0).
self storePointerUnchecked: HomeIndex ofObject: newContext withValue: methodContext.
self storePointerUnchecked: SenderIndex ofObject: newContext withValue: nilObj.
self pop: 2 thenPush: newContext.!
Item was changed:
----- Method: Interpreter>>primitiveClipboardText (in category 'I/O primitives') -----
primitiveClipboardText
"When called with a single string argument, post the string to
the clipboard. When called with zero arguments, return a
string containing the current clipboard contents."
| s sz |
argumentCount = 1
ifTrue: [s := self stackTop.
(self isBytes: s) ifFalse: [^ self primitiveFail].
successFlag
ifTrue: [sz := self stSizeOf: s.
+ self clipboardWrite: sz From: s + self baseHeaderSize At: 0.
- self clipboardWrite: sz From: s + BaseHeaderSize At: 0.
self pop: 1]]
ifFalse: [sz := self clipboardSize.
(self sufficientSpaceToAllocate: sz) ifFalse:[^self primitiveFail].
s := self instantiateClass: (self splObj: ClassByteString) indexableSize: sz.
+ self clipboardRead: sz Into: s + self baseHeaderSize At: 0.
- self clipboardRead: sz Into: s + BaseHeaderSize At: 0.
self pop: 1 thenPush: s]!
Item was changed:
----- Method: Interpreter>>primitiveClosureCopyWithCopiedValues (in category 'control primitives') -----
primitiveClosureCopyWithCopiedValues
| newClosure copiedValues numCopiedValues numArgs |
numArgs := self stackIntegerValue: 1.
copiedValues := self stackTop.
self success: (self fetchClassOf: copiedValues) = (self splObj: ClassArray).
successFlag ifFalse:
[^self primitiveFail].
numCopiedValues := self numSlotsOf: copiedValues.
newClosure := self
closureNumArgs: numArgs
"greater by 1 due to preIncrement of localIP"
+ instructionPointer: instructionPointer + 2 - (method+self baseHeaderSize)
- instructionPointer: instructionPointer + 2 - (method+BaseHeaderSize)
numCopiedValues: numCopiedValues.
"Assume: have just allocated a new closure; it must be young. Thus, can use unchecked stores."
self storePointerUnchecked: ClosureOuterContextIndex ofObject: newClosure withValue: (self stackValue: 2).
numCopiedValues > 0 ifTrue:
["Allocation may have done a GC and copiedValues may have moved."
copiedValues := self stackTop.
0 to: numCopiedValues - 1 do:
[:i|
"Assume: have just allocated a new BlockClosure; it must be young.
Thus, can use unchecked stores."
self storePointerUnchecked: i + ClosureFirstCopiedValueIndex
ofObject: newClosure
withValue: (self fetchPointer: i ofObject: copiedValues)]].
self pop: 3 thenPush: newClosure!
Item was changed:
----- Method: Interpreter>>primitiveConstantFill (in category 'sound primitives') -----
primitiveConstantFill
"Fill the receiver, which must be an indexable bytes or words
objects, with the given integer value."
| fillValue rcvr rcvrIsBytes end i |
<var: #end type: 'usqInt'>
<var: #i type: 'usqInt'>
fillValue := self positive32BitValueOf: self stackTop.
rcvr := self stackValue: 1.
self success: (self isWordsOrBytes: rcvr).
rcvrIsBytes := self isBytes: rcvr.
rcvrIsBytes ifTrue: [self success: (fillValue >= 0 and: [fillValue <= 255])].
successFlag
ifTrue: [end := rcvr + (self sizeBitsOf: rcvr).
+ i := rcvr + self baseHeaderSize.
- i := rcvr + BaseHeaderSize.
rcvrIsBytes
ifTrue: [[i < end]
whileTrue: [self byteAt: i put: fillValue.
i := i + 1]]
ifFalse: [[i < end]
whileTrue: [self long32At: i put: fillValue.
i := i + 4]].
self pop: 1]!
Item was changed:
----- Method: Interpreter>>primitiveExternalCall (in category 'plugin primitives') -----
primitiveExternalCall
"Call an external primitive. The external primitive methods
contain as first literal an array consisting of:
* The module name (String | Symbol)
* The function name (String | Symbol)
* The session ID (SmallInteger) [OBSOLETE]
* The function index (Integer) in the externalPrimitiveTable
For fast failures the primitive index of any method where the
external prim is not found is rewritten in the method cache
with zero. This allows for ultra fast responses as long as the
method stays in the cache.
The fast failure response relies on lkupClass being properly
set. This is done in
#addToMethodCacheSel:class:method:primIndex: to
compensate for execution of methods that are looked up in a
superclass (such as in primitivePerformAt).
With the latest modifications (e.g., actually flushing the
function addresses from the VM), the session ID is obsolete.
But for backward compatibility it is still kept around. Also, a
failed lookup is reported specially. If a method has been
looked up and not been found, the function address is stored
as -1 (e.g., the SmallInteger -1 to distinguish from
16rFFFFFFFF which may be returned from the lookup).
It is absolutely okay to remove the rewrite if we run into any
problems later on. It has an approximate speed difference of
30% per failed primitive call which may be noticable but if,
for any reasons, we run into problems (like with J3) we can
always remove the rewrite.
"
| lit addr moduleName functionName moduleLength functionLength index |
<var: #addr type: 'void *'>
"Fetch the first literal of the method"
self success: (self literalCountOf: newMethod) > 0. "@@: Could this be omitted for speed?!!"
successFlag ifFalse: [^ nil].
lit := self literal: 0 ofMethod: newMethod.
"Check if it's an array of length 4"
self success: ((self isArray: lit) and: [(self lengthOf: lit) = 4]).
successFlag ifFalse: [^ nil].
"Look at the function index in case it has been loaded before"
index := self fetchPointer: 3 ofObject: lit.
index := self checkedIntegerValueOf: index.
successFlag ifFalse: [^ nil].
"Check if we have already looked up the function and failed."
index < 0
ifTrue: ["Function address was not found in this session,
Rewrite the mcache entry with a zero primitive index."
self
rewriteMethodCacheSel: messageSelector
class: lkupClass
primIndex: 0.
^ self success: false].
"Try to call the function directly"
(index > 0 and: [index <= MaxExternalPrimitiveTableSize])
ifTrue: [addr := externalPrimitiveTable at: index - 1.
addr ~= 0
ifTrue: [self rewriteMethodCacheSel: messageSelector class: lkupClass primIndex: (1000 + index) primFunction: addr.
self callExternalPrimitive: addr.
^ nil].
"if we get here, then an index to the external prim was
kept on the ST side although the underlying prim
table was already flushed"
^ self primitiveFail].
"Clean up session id and external primitive index"
self storePointerUnchecked: 2 ofObject: lit withValue: ConstZero.
self storePointerUnchecked: 3 ofObject: lit withValue: ConstZero.
"The function has not been loaded yet. Fetch module and function name."
moduleName := self fetchPointer: 0 ofObject: lit.
moduleName = nilObj
ifTrue: [moduleLength := 0]
ifFalse: [self success: (self isBytes: moduleName).
moduleLength := self lengthOf: moduleName.
self cCode: '' inSmalltalk:
[ (#('FloatArrayPlugin' 'Matrix2x3Plugin') includes: (self stringOf: moduleName))
ifTrue: [moduleLength := 0 "Cause all of these to fail"]]].
functionName := self fetchPointer: 1 ofObject: lit.
self success: (self isBytes: functionName).
functionLength := self lengthOf: functionName.
successFlag ifFalse: [^ nil].
+ addr := self ioLoadExternalFunction: functionName + self baseHeaderSize
- addr := self ioLoadExternalFunction: functionName + BaseHeaderSize
OfLength: functionLength
+ FromModule: moduleName + self baseHeaderSize
- FromModule: moduleName + BaseHeaderSize
OfLength: moduleLength.
addr = 0
ifTrue: [index := -1]
ifFalse: ["add the function to the external primitive table"
index := self addToExternalPrimitiveTable: addr].
self success: index >= 0.
"Store the index (or -1 if failure) back in the literal"
self storePointerUnchecked: 3 ofObject: lit withValue: (self integerObjectOf: index).
"If the function has been successfully loaded process it"
(successFlag and: [addr ~= 0])
ifTrue: [self rewriteMethodCacheSel: messageSelector class: lkupClass primIndex: (1000 + index) primFunction: addr.
self callExternalPrimitive: addr]
ifFalse: ["Otherwise rewrite the primitive index"
self
rewriteMethodCacheSel: messageSelector
class: lkupClass
primIndex: 0]!
Item was changed:
----- Method: Interpreter>>primitiveGetAttribute (in category 'system control primitives') -----
primitiveGetAttribute
"Fetch the system attribute with the given integer ID. The
result is a string, which will be empty if the attribute is not
defined."
| attr sz s |
attr := self stackIntegerValue: 0.
successFlag
ifTrue: [sz := self attributeSize: attr].
successFlag
ifTrue: [s := self
instantiateClass: (self splObj: ClassByteString)
indexableSize: sz.
self
getAttribute: attr
+ Into: s + self baseHeaderSize
- Into: s + BaseHeaderSize
Length: sz.
self pop: 2 thenPush: s]!
Item was changed:
----- Method: Interpreter>>primitiveImageName (in category 'other primitives') -----
primitiveImageName
"When called with a single string argument, record the string as the current image file name. When called with zero arguments, return a string containing the current image file name."
| s sz sCRIfn okToRename |
<var: #sCRIfn type: 'void *'>
argumentCount = 1 ifTrue: [
"If the security plugin can be loaded, use it to check for rename permission.
If not, assume it's ok"
sCRIfn := self ioLoadFunction: 'secCanRenameImage' From: 'SecurityPlugin'.
sCRIfn ~= 0 ifTrue:[okToRename := self cCode:' ((sqInt (*)(void))sCRIfn)()'.
okToRename ifFalse:[^self primitiveFail]].
s := self stackTop.
self assertClassOf: s is: (self splObj: ClassByteString).
successFlag ifTrue: [
sz := self stSizeOf: s.
+ self imageNamePut: (s + self baseHeaderSize) Length: sz.
- self imageNamePut: (s + BaseHeaderSize) Length: sz.
self pop: 1. "pop s, leave rcvr on stack"
].
] ifFalse: [
sz := self imageNameSize.
s := self instantiateClass: (self splObj: ClassByteString) indexableSize: sz.
+ self imageNameGet: (s + self baseHeaderSize) Length: sz.
- self imageNameGet: (s + BaseHeaderSize) Length: sz.
self pop: 1. "rcvr"
self push: s.
].
!
Item was changed:
----- Method: Interpreter>>primitiveIntegerAt (in category 'sound primitives') -----
primitiveIntegerAt
"Return the 32bit signed integer contents of a words receiver"
| index rcvr sz addr value intValue |
<var: #intValue type: 'int'>
index := self stackIntegerValue: 0.
rcvr := self stackValue: 1.
(self isIntegerObject: rcvr) ifTrue: [^self success: false].
(self isWords: rcvr) ifFalse: [^self success: false].
sz := self lengthOf: rcvr. "number of fields"
self success: ((index >= 1) and: [index <= sz]).
successFlag ifTrue: [
+ addr := rcvr + self baseHeaderSize + (index - 1 * self wordSize). "for zero indexing"
- addr := rcvr + BaseHeaderSize + (index - 1 * BytesPerWord). "for zero indexing"
value := self intAt: addr.
self pop: 2. "pop rcvr, index"
"push element value"
(self isIntegerValue: value)
ifTrue: [self pushInteger: value]
ifFalse: [
intValue := value. "32 bit int may have been stored in 32 or 64 bit sqInt"
self push: (self signed32BitIntegerFor: intValue)]. "intValue may be sign extended to 64 bit sqInt"
].!
Item was changed:
----- Method: Interpreter>>primitiveIntegerAtPut (in category 'sound primitives') -----
primitiveIntegerAtPut
"Return the 32bit signed integer contents of a words receiver"
| index rcvr sz addr value valueOop |
valueOop := self stackValue: 0.
index := self stackIntegerValue: 1.
rcvr := self stackValue: 2.
(self isIntegerObject: rcvr) ifTrue:[^self success: false].
(self isWords: rcvr) ifFalse:[^self success: false].
sz := self lengthOf: rcvr. "number of fields"
((index >= 1) and: [index <= sz]) ifFalse:[^self success: false].
value := self signed32BitValueOf: valueOop.
successFlag ifTrue:[
+ addr := rcvr + self baseHeaderSize + (index - 1 * self wordSize). "for zero indexing"
- addr := rcvr + BaseHeaderSize + (index - 1 * BytesPerWord). "for zero indexing"
value := self intAt: addr put: value.
self pop: 3 thenPush: valueOop. "pop all; return value"
].
!
Item was changed:
----- Method: Interpreter>>primitiveInvokeObjectAsMethod (in category 'control primitives') -----
primitiveInvokeObjectAsMethod
"Primitive. 'Invoke' an object like a function, sending the special message
run: originalSelector with: arguments in: aReceiver.
"
| runSelector runReceiver runArgs newReceiver lookupClass |
runArgs := self instantiateClass: (self splObj: ClassArray) indexableSize: argumentCount.
self beRootIfOld: runArgs. "do we really need this?"
+ self transfer: argumentCount from: stackPointer - ((argumentCount - 1) * self wordSize) to: runArgs + self baseHeaderSize.
- self transfer: argumentCount from: stackPointer - ((argumentCount - 1) * BytesPerWord) to: runArgs + BaseHeaderSize.
runSelector := messageSelector.
runReceiver := self stackValue: argumentCount.
self pop: argumentCount+1.
"stack is clean here"
newReceiver := newMethod.
messageSelector := self splObj: SelectorRunWithIn.
argumentCount := 3.
self push: newReceiver.
self push: runSelector.
self push: runArgs.
self push: runReceiver.
lookupClass := self fetchClassOf: newReceiver.
self findNewMethodInClass: lookupClass.
self executeNewMethod. "Recursive xeq affects successFlag"
successFlag := true.
!
Item was changed:
----- Method: Interpreter>>primitiveLoadImageSegment (in category 'image segment in/out') -----
primitiveLoadImageSegment
"This primitive is called from Squeak as...
<imageSegment> loadSegmentFrom: aWordArray outPointers: anArray."
"This primitive will load a binary image segment created by primitiveStoreImageSegment. It expects the outPointer array to be of the proper size, and the wordArray to be well formed. It will return as its value the original array of roots, and the erstwhile segmentWordArray will have been truncated to a size of zero. If this primitive should fail, the segmentWordArray will, sadly, have been reduced to an unrecognizable and unusable jumble. But what more could you have done with it anyway?"
| outPointerArray segmentWordArray endSeg segOop fieldPtr fieldOop doingClass lastPtr extraSize mapOop lastOut outPtr hdrTypeBits header data |
<var: #endSeg type: 'usqInt'>
<var: #segOop type: 'usqInt'>
<var: #fieldPtr type: 'usqInt'>
<var: #lastOut type: 'usqInt'>
<var: #outPtr type: 'usqInt'>
<var: #lastPtr type: 'usqInt'>
DoAssertionChecks ifTrue: [self verifyCleanHeaders].
outPointerArray := self stackTop.
lastOut := outPointerArray + (self lastPointerOf: outPointerArray).
segmentWordArray := self stackValue: 1.
+ endSeg := segmentWordArray + (self sizeBitsOf: segmentWordArray) - self baseHeaderSize.
- endSeg := segmentWordArray + (self sizeBitsOf: segmentWordArray) - BaseHeaderSize.
"Essential type checks"
((self formatOf: outPointerArray) = 2 "Must be indexable pointers"
and: [(self formatOf: segmentWordArray) = 6]) "Must be indexable words"
ifFalse: [^ self primitiveFail].
"Version check. Byte order of the WordArray now"
+ data := self longAt: segmentWordArray + self baseHeaderSize.
- data := self longAt: segmentWordArray + BaseHeaderSize.
(self readableFormat: (data bitAnd: 16rFFFF "low 2 bytes")) ifFalse: [
"Not readable -- try again with reversed bytes..."
+ self reverseBytesFrom: segmentWordArray + self baseHeaderSize to: endSeg + self wordSize.
+ data := self longAt: segmentWordArray + self baseHeaderSize.
- self reverseBytesFrom: segmentWordArray + BaseHeaderSize to: endSeg + BytesPerWord.
- data := self longAt: segmentWordArray + BaseHeaderSize.
(self readableFormat: (data bitAnd: 16rFFFF "low 2 bytes")) ifFalse: [
"Still NG -- put things back and fail"
+ self reverseBytesFrom: segmentWordArray + self baseHeaderSize to: endSeg + self wordSize.
- self reverseBytesFrom: segmentWordArray + BaseHeaderSize to: endSeg + BytesPerWord.
DoAssertionChecks ifTrue: [self verifyCleanHeaders].
^ self primitiveFail]].
"Reverse the Byte type objects if the is data from opposite endian machine."
"Test top byte. $d on the Mac or $s on the PC. Rest of word is equal."
(data >> 16) = (self imageSegmentVersion >> 16) ifFalse: [
"Reverse the byte-type objects once"
+ segOop := self oopFromChunk: segmentWordArray + self baseHeaderSize + self wordSize.
- segOop := self oopFromChunk: segmentWordArray + BaseHeaderSize + BytesPerWord.
"Oop of first embedded object"
+ self byteSwapByteObjectsFrom: segOop to: endSeg + self wordSize].
- self byteSwapByteObjectsFrom: segOop to: endSeg + BytesPerWord].
"Proceed through the segment, remapping pointers..."
+ segOop := self oopFromChunk: segmentWordArray + self baseHeaderSize + self wordSize.
- segOop := self oopFromChunk: segmentWordArray + BaseHeaderSize + BytesPerWord.
[segOop <= endSeg] whileTrue:
[(self headerType: segOop) <= 1
ifTrue: ["This object has a class field (type = 0 or 1) -- start with that."
+ fieldPtr := segOop - self wordSize. doingClass := true]
- fieldPtr := segOop - BytesPerWord. doingClass := true]
ifFalse: ["No class field -- start with first data field"
+ fieldPtr := segOop + self baseHeaderSize. doingClass := false].
- fieldPtr := segOop + BaseHeaderSize. doingClass := false].
lastPtr := segOop + (self lastPointerOf: segOop). "last field"
lastPtr > endSeg ifTrue: [
DoAssertionChecks ifTrue: [self verifyCleanHeaders].
^ self primitiveFail "out of bounds"].
"Go through all oops, remapping them..."
[fieldPtr > lastPtr] whileFalse:
["Examine each pointer field"
fieldOop := self longAt: fieldPtr.
doingClass ifTrue:
[hdrTypeBits := self headerType: fieldPtr.
fieldOop := fieldOop - hdrTypeBits].
(self isIntegerObject: fieldOop)
ifTrue:
["Integer -- nothing to do"
+ fieldPtr := fieldPtr + self wordSize]
- fieldPtr := fieldPtr + BytesPerWord]
ifFalse:
[(fieldOop bitAnd: 3) = 0 ifFalse: [^ self primitiveFail "bad oop"].
(fieldOop bitAnd: 16r80000000) = 0
ifTrue: ["Internal pointer -- add segment offset"
mapOop := fieldOop + segmentWordArray]
ifFalse: ["External pointer -- look it up in outPointers"
outPtr := outPointerArray + (fieldOop bitAnd: 16r7FFFFFFF).
outPtr > lastOut ifTrue: [^ self primitiveFail "out of bounds"].
mapOop := self longAt: outPtr].
doingClass
ifTrue: [self longAt: fieldPtr put: mapOop + hdrTypeBits.
fieldPtr := fieldPtr + 8.
doingClass := false]
ifFalse: [self longAt: fieldPtr put: mapOop.
+ fieldPtr := fieldPtr + self wordSize].
- fieldPtr := fieldPtr + BytesPerWord].
segOop < youngStart
ifTrue: [self possibleRootStoreInto: segOop value: mapOop].
]].
segOop := self objectAfter: segOop].
"Again, proceed through the segment checking consistency..."
+ segOop := self oopFromChunk: segmentWordArray + self baseHeaderSize + self wordSize.
- segOop := self oopFromChunk: segmentWordArray + BaseHeaderSize + BytesPerWord.
[segOop <= endSeg] whileTrue:
[(self oopHasAcceptableClass: segOop) ifFalse: [^ self primitiveFail "inconsistency"].
+ fieldPtr := segOop + self baseHeaderSize. "first field"
- fieldPtr := segOop + BaseHeaderSize. "first field"
lastPtr := segOop + (self lastPointerOf: segOop). "last field"
"Go through all oops, remapping them..."
[fieldPtr > lastPtr] whileFalse:
["Examine each pointer field"
fieldOop := self longAt: fieldPtr.
(self oopHasAcceptableClass: fieldOop) ifFalse: [^ self primitiveFail "inconsistency"].
+ fieldPtr := fieldPtr + self wordSize].
- fieldPtr := fieldPtr + BytesPerWord].
segOop := self objectAfter: segOop].
"Truncate the segment word array to size = BytesPerWord (vers stamp only)"
extraSize := self extraHeaderBytes: segmentWordArray.
hdrTypeBits := self headerType: segmentWordArray.
extraSize = 8
+ ifTrue: [self longAt: segmentWordArray-extraSize put: self baseHeaderSize + self wordSize + hdrTypeBits]
- ifTrue: [self longAt: segmentWordArray-extraSize put: BaseHeaderSize + BytesPerWord + hdrTypeBits]
ifFalse: [header := self longAt: segmentWordArray.
self longAt: segmentWordArray
+ put: header - (header bitAnd: SizeMask) + self baseHeaderSize + self wordSize].
- put: header - (header bitAnd: SizeMask) + BaseHeaderSize + BytesPerWord].
"and return the roots array which was first in the segment"
DoAssertionChecks ifTrue: [self verifyCleanHeaders].
+ self pop: 3 thenPush: (self oopFromChunk: segmentWordArray + self baseHeaderSize + self wordSize).
- self pop: 3 thenPush: (self oopFromChunk: segmentWordArray + BaseHeaderSize + BytesPerWord).
!
Item was changed:
----- Method: Interpreter>>primitiveNewMethod (in category 'compiled methods') -----
primitiveNewMethod
| header bytecodeCount class size theMethod literalCount |
header := self popStack.
bytecodeCount := self popInteger.
self success: (self isIntegerObject: header).
successFlag ifFalse:
[self unPop: 2. ^nil].
class := self popStack.
+ size := (self literalCountOfMethodHeader: header) + 1 * self wordSize + bytecodeCount.
- size := (self literalCountOfMethodHeader: header) + 1 * BytesPerWord + bytecodeCount.
theMethod := self instantiateClass: class indexableSize: size.
self storePointerUnchecked: HeaderIndex ofObject: theMethod withValue: header.
literalCount := self literalCountOfMethodHeader: header.
1 to: literalCount do:
[:i | self storePointer: i ofObject: theMethod withValue: nilObj].
self push: theMethod!
Item was changed:
----- Method: Interpreter>>primitiveObjectPointsTo (in category 'object access primitives') -----
primitiveObjectPointsTo
| rcvr thang lastField |
thang := self popStack.
rcvr := self popStack.
(self isIntegerObject: rcvr) ifTrue: [^self pushBool: false].
lastField := self lastPointerOf: rcvr.
+ self baseHeaderSize to: lastField by: self wordSize do:
- BaseHeaderSize to: lastField by: BytesPerWord do:
[:i | (self longAt: rcvr + i) = thang
ifTrue: [^ self pushBool: true]].
self pushBool: false.!
Item was changed:
----- Method: Interpreter>>primitiveShortAt (in category 'sound primitives') -----
primitiveShortAt
"Treat the receiver, which can be indexible by either bytes or words, as an array of signed 16-bit values. Return the contents of the given index. Note that the index specifies the i-th 16-bit entry, not the i-th byte or word."
| index rcvr sz addr value |
index := self stackIntegerValue: 0.
rcvr := self stackValue: 1.
self success: ((self isIntegerObject: rcvr) not and: [self isWordsOrBytes: rcvr]).
successFlag ifFalse: [ ^ nil ].
+ sz := ((self sizeBitsOf: rcvr) - self baseHeaderSize) // 2. "number of 16-bit fields"
- sz := ((self sizeBitsOf: rcvr) - BaseHeaderSize) // 2. "number of 16-bit fields"
self success: ((index >= 1) and: [index <= sz]).
successFlag ifTrue: [
+ addr := rcvr + self baseHeaderSize + (2 * (index - 1)).
- addr := rcvr + BaseHeaderSize + (2 * (index - 1)).
value := self shortAt: addr.
self pop: 2 thenPushInteger: value.
]!
Item was changed:
----- Method: Interpreter>>primitiveShortAtPut (in category 'sound primitives') -----
primitiveShortAtPut
"Treat the receiver, which can be indexible by either bytes or words, as an array of signed 16-bit values. Set the contents of the given index to the given value. Note that the index specifies the i-th 16-bit entry, not the i-th byte or word."
| index rcvr sz addr value |
value := self stackIntegerValue: 0.
index := self stackIntegerValue: 1.
rcvr := self stackValue: 2.
self success: ((self isIntegerObject: rcvr) not and: [self isWordsOrBytes: rcvr]).
successFlag ifFalse: [ ^ nil ].
+ sz := ((self sizeBitsOf: rcvr) - self baseHeaderSize) // 2. "number of 16-bit fields"
- sz := ((self sizeBitsOf: rcvr) - BaseHeaderSize) // 2. "number of 16-bit fields"
self success: ((index >= 1) and: [index <= sz]).
self success: ((value >= -32768) and: [value <= 32767]).
successFlag ifTrue: [
+ addr := rcvr + self baseHeaderSize + (2 * (index - 1)).
- addr := rcvr + BaseHeaderSize + (2 * (index - 1)).
self shortAt: addr put: value.
self pop: 2. "pop index and value; leave rcvr on stack"
]!
Item was changed:
----- Method: Interpreter>>primitiveStoreStackp (in category 'object access primitives') -----
primitiveStoreStackp
"Atomic store into context stackPointer.
Also ensures that any newly accessible cells are initialized to nil "
| ctxt newStackp stackp |
ctxt := self stackValue: 1.
newStackp := self stackIntegerValue: 0.
+ self success: newStackp >= 0.
+ self success: newStackp <= (LargeContextSlots - CtxtTempFrameStart).
- self success: (self oop: newStackp isGreaterThanOrEqualTo: 0).
- self success: (self oop: newStackp isLessThanOrEqualTo: (LargeContextSize - BaseHeaderSize // BytesPerWord - CtxtTempFrameStart)).
successFlag ifFalse: [^ self primitiveFail].
stackp := self fetchStackPointerOf: ctxt.
"Nil any newly accessible cells"
stackp + 1 to: newStackp do:
[:i | self storePointerUnchecked: i + CtxtTempFrameStart - 1 ofObject: ctxt withValue: nilObj].
self storeStackPointerValue: newStackp inContext: ctxt.
self pop: 1!
Item was changed:
----- Method: Interpreter>>primitiveVMParameter (in category 'system control primitives') -----
(excessive size, no diff calculated)
Item was changed:
----- Method: Interpreter>>primitiveVMPath (in category 'system control primitives') -----
primitiveVMPath
"Return a string containing the path name of VM's directory."
| s sz |
sz := self vmPathSize.
s := self instantiateClass: (self splObj: ClassByteString) indexableSize: sz.
+ self vmPathGet: (s + self baseHeaderSize) Length: sz.
- self vmPathGet: (s + BaseHeaderSize) Length: sz.
self pop: 1 thenPush: s.
!
Item was changed:
----- Method: Interpreter>>printNameOfClass:count: (in category 'debug printing') -----
printNameOfClass: classOop count: cnt
"Details: The count argument is used to avoid a possible infinite recursion if classOop is a corrupted object."
cnt <= 0 ifTrue: [^self print: 'bad class'].
((self sizeBitsOf: classOop) = metaclassSizeBits
+ and: [metaclassSizeBits >= (6 * self wordSize)]) "(Metaclass instSize * 4)"
- and: [metaclassSizeBits >= (6 * BytesPerWord)]) "(Metaclass instSize * 4)"
ifTrue: [self printNameOfClass: (self fetchPointer: 5 "thisClass" ofObject: classOop) count: cnt - 1.
self print: ' class']
ifFalse: [self printStringOf: (self fetchPointer: 6 "name" ofObject: classOop)]!
Item was changed:
----- Method: Interpreter>>printOop: (in category 'debug printing') -----
printOop: oop
| fmt lastIndex |
<inline: false>
self printNum: oop.
(self isIntegerObject: oop) ifTrue:
[^self cCode: 'printf("=%ld\n", (long)integerValueOf(oop))' inSmalltalk: [self shortPrint: oop]].
self print: ': a(n) '.
self printNameOfClass: (self fetchClassOf: oop) count: 5.
self cr.
fmt := self formatOf: oop.
(fmt > 4 and: [fmt < 12]) ifTrue:
[^self printStringOf: oop].
+ lastIndex := 64 min: ((self lastPointerOf: oop) / self wordSize).
- lastIndex := 64 min: ((self lastPointerOf: oop) / BytesPerWord).
lastIndex > 0 ifTrue:
[1 to: lastIndex do:
[:index|
self cCode: 'printf(" %ld", fetchPointerofObject(index - 1, oop))'
inSmalltalk: [self space; print: (self fetchPointer: index - 1 ofObject: oop) printString; space.
self print: (self shortPrint: (self fetchPointer: index - 1 ofObject: oop))].
(index \\ 8) = 0 ifTrue:
[self cr]].
(lastIndex \\ 8) = 0 ifFalse:
[self cr]]!
Item was changed:
----- Method: Interpreter>>push: (in category 'contexts') -----
push: object
| sp |
+ self longAt: (sp := stackPointer + self wordSize) put: object.
- self longAt: (sp := stackPointer + BytesPerWord) put: object.
stackPointer := sp.!
Item was changed:
----- Method: Interpreter>>pushClosureCopyCopiedValuesBytecode (in category 'stack bytecodes') -----
pushClosureCopyCopiedValuesBytecode
"The compiler has pushed the values to be copied, if any. Find numArgs and numCopied in the byte following.
Create a Closure with space for the copiedValues and pop numCopied values off the stack into the closure.
Set numArgs as specified, and set startpc to the pc following the block size and jump over that code."
| newClosure numArgsNumCopied numArgs numCopied blockSize |
numArgsNumCopied := self fetchByte.
numArgs := numArgsNumCopied bitAnd: 16rF.
numCopied := numArgsNumCopied bitShift: -4.
"Split blockSize := (self fetchByte * 256) + self fetchByte. into two because evaluation order in C is undefined."
blockSize := self fetchByte << 8.
blockSize := blockSize + self fetchByte.
self externalizeIPandSP. "This is a pain."
newClosure := self
closureNumArgs: numArgs
+ instructionPointer: ((self cCoerce: localIP to: 'sqInt') + 2 - (method+self baseHeaderSize))
- instructionPointer: ((self cCoerce: localIP to: 'sqInt') + 2 - (method+BaseHeaderSize))
numCopiedValues: numCopied.
self internalizeIPandSP.
"Assume: have just allocated a new closure; it must be young. Thus, can use unchecked stores."
self storePointerUnchecked: ClosureOuterContextIndex ofObject: newClosure withValue: activeContext.
reclaimableContextCount := 0. "The closure refers to thisContext so it can't be reclaimed."
numCopied > 0 ifTrue:
[0 to: numCopied - 1 do:
[:i|
"Assume: have just allocated a new BlockClosure; it must be young.
Thus, can use unchecked stores."
self storePointerUnchecked: i + ClosureFirstCopiedValueIndex
ofObject: newClosure
withValue: (self internalStackValue: numCopied - i - 1)].
self internalPop: numCopied].
localIP := localIP + blockSize.
self fetchNextBytecode.
self internalPush: newClosure!
Item was changed:
----- Method: Interpreter>>readImageFromFile:HeapSize:StartingAt: (in category 'image save/restore') -----
readImageFromFile: f HeapSize: desiredHeapSize StartingAt: imageOffset
"Read an image from the given file stream, allocating the given amount of memory to its object heap. Fail if the image has an unknown format or requires more than the given amount of memory."
"Details: This method detects when the image was stored on a machine with the opposite byte ordering from this machine and swaps the bytes automatically. Furthermore, it allows the header information to start 512 bytes into the file, since some file transfer programs for the Macintosh apparently prepend a Mac-specific header of this size. Note that this same 512 bytes of prefix area could also be used to store an exec command on Unix systems, allowing one to launch Smalltalk by invoking the image name as a command."
"This code is based on C code by Ian Piumarta and Smalltalk code by Tim Rowledge. Many thanks to both of you!!!!"
| swapBytes headerStart headerSize dataSize oldBaseAddr minimumMemory memStart bytesRead bytesToShift heapSize |
<var: #f type: 'sqImageFile '>
<var: #desiredHeapSize type: 'usqInt'>
<var: #headerStart type: 'squeakFileOffsetType '>
<var: #dataSize type: 'size_t '>
<var: #imageOffset type: 'squeakFileOffsetType '>
+ metaclassSizeBits := 6 * self wordSize. "guess (Metaclass instSize * BPW)"
- metaclassSizeBits := 6 * BytesPerWord. "guess (Metaclass instSize * BPW)"
swapBytes := self checkImageVersionFrom: f startingAt: imageOffset.
+ headerStart := (self sqImageFilePosition: f) - self wordSize. "record header start position"
- headerStart := (self sqImageFilePosition: f) - BytesPerWord. "record header start position"
headerSize := self getLongFromFile: f swap: swapBytes.
dataSize := self getLongFromFile: f swap: swapBytes.
oldBaseAddr := self getLongFromFile: f swap: swapBytes.
specialObjectsOop := self getLongFromFile: f swap: swapBytes.
lastHash := self getLongFromFile: f swap: swapBytes.
savedWindowSize := self getLongFromFile: f swap: swapBytes.
fullScreenFlag := self getLongFromFile: f swap: swapBytes.
extraVMMemory := self getLongFromFile: f swap: swapBytes.
lastHash = 0 ifTrue: [
"lastHash wasn't stored (e.g. by the cloner); use 999 as the seed"
lastHash := 999].
"decrease Squeak object heap to leave extra memory for the VM"
heapSize := self cCode: 'reserveExtraCHeapBytes(desiredHeapSize, extraVMMemory)'.
"compare memory requirements with availability".
minimumMemory := dataSize + 100000. "need at least 100K of breathing room"
heapSize < minimumMemory ifTrue: [
self insufficientMemorySpecifiedError].
"allocate a contiguous block of memory for the Squeak heap"
memory := self cCode: 'sqAllocateMemory(minimumMemory, heapSize)'.
memory = nil ifTrue: [self insufficientMemoryAvailableError].
memStart := self startOfMemory.
self setMemoryLimit: (memStart + heapSize) - 24. "decrease memoryLimit a tad for safety"
self 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].
swapBytes ifTrue: [self reverseBytesInImage].
"compute difference between old and new memory base addresses"
bytesToShift := memStart - oldBaseAddr.
self initializeInterpreter: bytesToShift. "adjusts all oops to new location"
^ dataSize
!
Item was changed:
----- Method: Interpreter>>reverseDisplayFrom:to: (in category 'I/O primitive support') -----
reverseDisplayFrom: startIndex to: endIndex
"Reverse the given range of Display words (at different bit
depths, this will reverse different numbers of pixels). Used to
give feedback during VM activities such as garbage
collection when debugging. It is assumed that the given
word range falls entirely within the first line of the Display."
| displayObj dispBitsPtr w reversed |
displayObj := self splObj: TheDisplay.
((self isPointers: displayObj) and: [(self lengthOf: displayObj) >= 4]) ifFalse: [^ nil].
w := self fetchInteger: 1 ofObject: displayObj.
dispBitsPtr := self fetchPointer: 0 ofObject: displayObj.
(self isIntegerObject: dispBitsPtr) ifTrue: [^ nil].
+ dispBitsPtr := dispBitsPtr + self baseHeaderSize.
- dispBitsPtr := dispBitsPtr + BaseHeaderSize.
dispBitsPtr + (startIndex * 4) to: dispBitsPtr + (endIndex * 4) by: 4
do: [:ptr |
reversed := (self long32At: ptr) bitXor: 4294967295.
self longAt: ptr put: reversed].
successFlag := true.
self displayBitsOf: displayObj Left: 0 Top: 0 Right: w Bottom: 1.
self ioForceDisplayUpdate!
Item was changed:
----- Method: Interpreter>>sendInvokeCallback:Stack:Registers:Jmpbuf: (in category 'callback support') -----
sendInvokeCallback: thunkPtr Stack: stackPtr Registers: regsPtr Jmpbuf: jmpBufPtr
"Send the 4 argument callback message invokeCallback:stack:registers:jmpbuf:
to Alien class with the supplied args. The arguments are raw C addresses
and are converted to integer objects on the way."
| where |
<export: true>
self pushRemappableOop: (self positive32BitIntegerFor: jmpBufPtr).
self pushRemappableOop: (self positive32BitIntegerFor: regsPtr).
self pushRemappableOop: (self positive32BitIntegerFor: stackPtr).
self pushRemappableOop: (self positive32BitIntegerFor: thunkPtr).
receiver := self splObj: ClassAlien.
lkupClass := self fetchClassOfNonImm: receiver.
messageSelector := self splObj: SelectorInvokeCallback.
(self lookupInMethodCacheSel: messageSelector class: lkupClass) ifFalse:
[(self lookupMethodNoMNUEtcInClass: lkupClass) ifFalse:
[^false]].
primitiveIndex ~= 0 ifTrue:
[^false].
self storeContextRegisters: activeContext.
self justActivateNewMethod.
+ where := activeContext + self baseHeaderSize + (ReceiverIndex << self shiftForWord).
+ self longAt: where + (1 << self shiftForWord) put: self popRemappableOop.
+ self longAt: where + (2 << self shiftForWord) put: self popRemappableOop.
+ self longAt: where + (3 << self shiftForWord) put: self popRemappableOop.
+ self longAt: where + (4 << self shiftForWord) put: self popRemappableOop.
- where := activeContext + BaseHeaderSize + (ReceiverIndex << ShiftForWord).
- self longAt: where + (1 << ShiftForWord) put: self popRemappableOop.
- self longAt: where + (2 << ShiftForWord) put: self popRemappableOop.
- self longAt: where + (3 << ShiftForWord) put: self popRemappableOop.
- self longAt: where + (4 << ShiftForWord) put: self popRemappableOop.
self interpret.
"not reached"
^true!
Item was changed:
----- Method: Interpreter>>sizeOfSTArrayFromCPrimitive: (in category 'utilities') -----
sizeOfSTArrayFromCPrimitive: cPtr
"Return the number of indexable fields of the given object. This method is to be called from an automatically generated C primitive. The argument is assumed to be a pointer to the first indexable field of a words or bytes object; the object header starts 4 bytes before that."
"Note: Only called by translated primitive code."
| oop |
<var: #cPtr type: 'void *'>
+ oop := (self oopForPointer: cPtr) - self baseHeaderSize.
- oop := (self oopForPointer: cPtr) - BaseHeaderSize.
(self isWordsOrBytes: oop) ifFalse: [
self primitiveFail.
^0].
^self lengthOf: oop
!
Item was changed:
----- Method: Interpreter>>snapshotCleanUp (in category 'image save/restore') -----
snapshotCleanUp
"Clean up right before saving an image, sweeping memory and:
* nilling out all fields of contexts above the stack pointer.
* flushing external primitives
* clearing the root bit of any object in the root table "
| oop header fmt sz |
oop := self firstObject.
[self oop: oop isLessThan: endOfMemory]
whileTrue: [(self isFreeObject: oop)
ifFalse: [header := self longAt: oop.
fmt := header >> 8 bitAnd: 15.
"Clean out context"
(fmt = 3 and: [self isContextHeader: header])
ifTrue: [sz := self sizeBitsOf: oop.
+ (self lastPointerOf: oop) + self wordSize
+ to: sz - self baseHeaderSize by: self wordSize
- (self lastPointerOf: oop) + BytesPerWord
- to: sz - BaseHeaderSize by: BytesPerWord
do: [:i | self longAt: oop + i put: nilObj]].
"Clean out external functions"
fmt >= 12
ifTrue: ["This is a compiled method"
(self primitiveIndexOf: oop) = PrimitiveExternalCallIndex
ifTrue: ["It's primitiveExternalCall"
self flushExternalPrimitiveOf: oop]]].
oop := self objectAfter: oop].
self clearRootsTable!
Item was changed:
----- Method: Interpreter>>stackFloatValue: (in category 'contexts') -----
stackFloatValue: offset
<returnTypeC: #double>
+ ^self floatValueOf: (self longAt: stackPointer - (offset*self wordSize))!
- ^self floatValueOf: (self longAt: stackPointer - (offset*BytesPerWord))!
Item was changed:
----- Method: Interpreter>>stackIntegerValue: (in category 'contexts') -----
stackIntegerValue: offset
| integerPointer |
+ integerPointer := self longAt: stackPointer - (offset*self wordSize).
- integerPointer := self longAt: stackPointer - (offset*BytesPerWord).
^self checkedIntegerValueOf: integerPointer!
Item was changed:
----- Method: Interpreter>>stackObjectValue: (in category 'contexts') -----
stackObjectValue: offset
"Ensures that the given object is a real object, not a SmallInteger."
| oop |
+ oop := self longAt: stackPointer - (offset * self wordSize).
- oop := self longAt: stackPointer - (offset * BytesPerWord).
(self isIntegerObject: oop) ifTrue: [self primitiveFail. ^ nil].
^ oop
!
Item was changed:
----- Method: Interpreter>>stackPointerIndex (in category 'contexts') -----
stackPointerIndex
"Return the 0-based index rel to the current context.
(This is what stackPointer used to be before conversion to pointer"
+ ^ (stackPointer - activeContext - self baseHeaderSize) >> self shiftForWord!
- ^ (stackPointer - activeContext - BaseHeaderSize) >> ShiftForWord!
Item was changed:
----- Method: Interpreter>>stackValue: (in category 'contexts') -----
stackValue: offset
+ ^ self longAt: stackPointer - (offset*self wordSize)!
- ^ self longAt: stackPointer - (offset*BytesPerWord)!
Item was changed:
----- Method: Interpreter>>storeContextRegisters: (in category 'contexts') -----
storeContextRegisters: activeCntx
"Note: internalStoreContextRegisters: should track changes to this method."
"InstructionPointer is a pointer variable equal to
method oop + ip + BaseHeaderSize
-1 for 0-based addressing of fetchByte
-1 because it gets incremented BEFORE fetching currentByte"
<inline: true>
self storePointerUnchecked: InstructionPointerIndex ofObject: activeCntx
+ withValue: (self integerObjectOf: (instructionPointer - method - (self baseHeaderSize - 2))).
- withValue: (self integerObjectOf: (instructionPointer - method - (BaseHeaderSize - 2))).
self storePointerUnchecked: StackPointerIndex ofObject: activeCntx
withValue: (self integerObjectOf: (self stackPointerIndex - TempFrameStart + 1)).
!
Item was changed:
----- Method: Interpreter>>transfer:fromIndex:ofObject:toIndex:ofObject: (in category 'utilities') -----
transfer: count fromIndex: firstFrom ofObject: fromOop toIndex: firstTo ofObject: toOop
"Transfer the specified fullword fields, as from calling context to called context"
"Assume: beRootIfOld: will be called on toOop."
| fromIndex toIndex lastFrom |
<inline: true>
self flag: #Dan. "Need to check all senders before converting this for 64 bits"
+ fromIndex := fromOop + (firstFrom * self wordSize).
+ toIndex := toOop + (firstTo * self wordSize).
+ lastFrom := fromIndex + (count * self wordSize).
- fromIndex := fromOop + (firstFrom * BytesPerWord).
- toIndex := toOop + (firstTo * BytesPerWord).
- lastFrom := fromIndex + (count * BytesPerWord).
[self oop: fromIndex isLessThan: lastFrom]
+ whileTrue: [fromIndex := fromIndex + self wordSize.
+ toIndex := toIndex + self wordSize.
- whileTrue: [fromIndex := fromIndex + BytesPerWord.
- toIndex := toIndex + BytesPerWord.
self
longAt: toIndex
put: (self longAt: fromIndex)]!
Item was changed:
----- Method: Interpreter>>unPop: (in category 'contexts') -----
unPop: nItems
+ stackPointer := stackPointer + (nItems*self wordSize)!
- stackPointer := stackPointer + (nItems*BytesPerWord)!
Item was changed:
----- Method: Interpreter>>wordSwapped: (in category 'image save/restore') -----
wordSwapped: w
"Return the given 64-bit integer with its halves in the reverse order."
+ self wordSize = 8 ifFalse: [self error: 'This cannot happen.'].
- BytesPerWord = 8 ifFalse: [self error: 'This cannot happen.'].
^ ((w bitShift: Byte4ShiftNegated) bitAnd: Bytes3to0Mask)
+ ((w bitShift: Byte4Shift ) bitAnd: Bytes7to4Mask)
!
Item was changed:
----- Method: InterpreterPlugin class>>buildCodeGeneratorUpTo: (in category 'translation') -----
buildCodeGeneratorUpTo: aPluginClass
"Build a CCodeGenerator for the plugin"
| cg pluginClasses |
cg := self codeGeneratorClass new initialize.
cg pluginClass: self.
(pluginClasses := self pluginClassesUpTo: aPluginClass) do:
[:aClass| cg addClass: aClass].
(cg structClassesForTranslationClasses: pluginClasses) do:
[:structClasss| cg addStructClass: structClasss].
- cg removeUnneededBuiltins.
^cg!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveBeCursor (in category 'I/O primitives') -----
primitiveBeCursor
"Set the cursor to the given shape. The Mac only supports 16x16 pixel cursors. Cursor offsets are handled by Smalltalk."
| cursorObj maskBitsIndex maskObj bitsObj extentX extentY depth offsetObj offsetX offsetY cursorBitsIndex ourCursor |
argumentCount = 0 ifTrue: [
cursorObj := self stackTop.
maskBitsIndex := nil].
argumentCount = 1 ifTrue: [
cursorObj := self stackValue: 1.
maskObj := self stackTop].
self success: argumentCount < 2.
self success: ((objectMemory isPointers: cursorObj) and: [(objectMemory lengthOf: cursorObj) >= 5]).
self successful ifTrue: [
bitsObj := objectMemory fetchPointer: 0 ofObject: cursorObj.
extentX := self fetchInteger: 1 ofObject: cursorObj.
extentY := self fetchInteger: 2 ofObject: cursorObj.
depth := self fetchInteger: 3 ofObject: cursorObj.
offsetObj := objectMemory fetchPointer: 4 ofObject: cursorObj].
self success: ((objectMemory isPointers: offsetObj) and: [(objectMemory lengthOf: offsetObj) >= 2]).
self successful ifTrue: [
offsetX := self fetchInteger: 0 ofObject: offsetObj.
offsetY := self fetchInteger: 1 ofObject: offsetObj.
(argumentCount = 0 and: [depth = 32])
ifTrue: [
"Support arbitrary-sized 32 bit ARGB forms --bf 3/1/2007 23:51"
self success: ((extentX > 0) and: [extentY > 0]).
self success: ((offsetX >= (extentX * -1)) and: [offsetX <= 0]).
self success: ((offsetY >= (extentY * -1)) and: [offsetY <= 0]).
self success: ((objectMemory isWords: bitsObj) and: [(objectMemory lengthOf: bitsObj) = (extentX * extentY)]).
+ cursorBitsIndex := bitsObj + objectMemory baseHeaderSize.
- cursorBitsIndex := bitsObj + BaseHeaderSize.
self cCode: '' inSmalltalk:
[ourCursor := Cursor
extent: extentX @ extentY
depth: 32
fromArray: ((1 to: extentX * extentY) collect: [:i |
objectMemory fetchLong32: i-1 ofObject: bitsObj])
offset: offsetX @ offsetY]]
ifFalse: [
self success: ((extentX = 16) and: [extentY = 16 and: [depth = 1]]).
self success: ((offsetX >= -16) and: [offsetX <= 0]).
self success: ((offsetY >= -16) and: [offsetY <= 0]).
self success: ((objectMemory isWords: bitsObj) and: [(objectMemory lengthOf: bitsObj) = 16]).
cursorBitsIndex := bitsObj + objectMemory baseHeaderSize.
self cCode: '' inSmalltalk:
[ourCursor := Cursor
extent: extentX @ extentY
fromArray: ((1 to: 16) collect: [:i |
((objectMemory fetchLong32: i-1 ofObject: bitsObj) >> (objectMemory wordSize*8 - 16)) bitAnd: 16rFFFF])
offset: offsetX @ offsetY]]].
argumentCount = 1 ifTrue: [
self success: ((objectMemory isPointers: maskObj) and: [(objectMemory lengthOf: maskObj) >= 5]).
self successful ifTrue: [
bitsObj := objectMemory fetchPointer: 0 ofObject: maskObj.
extentX := self fetchInteger: 1 ofObject: maskObj.
extentY := self fetchInteger: 2 ofObject: maskObj.
depth := self fetchInteger: 3 ofObject: maskObj].
self successful ifTrue: [
self success: ((extentX = 16) and: [extentY = 16 and: [depth = 1]]).
self success: ((objectMemory isWords: bitsObj) and: [(objectMemory lengthOf: bitsObj) = 16]).
maskBitsIndex := bitsObj + objectMemory baseHeaderSize]].
self successful ifTrue: [
argumentCount = 0
ifTrue: [
depth = 32
ifTrue: [(self cCode: 'ioSetCursorARGB(cursorBitsIndex, extentX, extentY, offsetX, offsetY)'
inSmalltalk: [ourCursor show. Cursor currentCursor == ourCursor])
ifFalse: [^self success: false]]
ifFalse: [self cCode: 'ioSetCursor(cursorBitsIndex, offsetX, offsetY)'
inSmalltalk: [ourCursor show]]]
ifFalse: [self cCode: 'ioSetCursorWithMask(cursorBitsIndex, maskBitsIndex, offsetX, offsetY)'
inSmalltalk: [cursorBitsIndex == maskBitsIndex. "placate compiler"
ourCursor show]].
self pop: argumentCount]!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveConstantFill (in category 'sound primitives') -----
primitiveConstantFill
"Fill the receiver, which must be an indexable bytes or words
objects, with the given integer value."
| fillValue rcvr rcvrIsBytes end i |
<var: #end type: #usqInt>
<var: #i type: #usqInt>
fillValue := self positive32BitValueOf: self stackTop.
rcvr := self stackValue: 1.
self success: (objectMemory isWordsOrBytes: rcvr).
rcvrIsBytes := objectMemory isBytes: rcvr.
rcvrIsBytes ifTrue: [self success: (fillValue >= 0 and: [fillValue <= 255])].
self successful ifTrue:
[end := rcvr + (objectMemory sizeBitsOf: rcvr).
+ i := rcvr + objectMemory baseHeaderSize.
- i := rcvr + BaseHeaderSize.
rcvrIsBytes
ifTrue: [[i < end] whileTrue:
[objectMemory byteAt: i put: fillValue.
i := i + 1]]
ifFalse: [[i < end] whileTrue:
[objectMemory long32At: i put: fillValue.
i := i + 4]].
self pop: 1]!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveGetAttribute (in category 'system control primitives') -----
primitiveGetAttribute
"Fetch the system attribute with the given integer ID. The
result is a string, which will be empty if the attribute is not
defined."
| attr sz s |
attr := self stackIntegerValue: 0.
self successful
ifTrue: [sz := self attributeSize: attr].
self successful
ifTrue: [s := objectMemory
instantiateClass: (objectMemory splObj: ClassByteString)
indexableSize: sz.
self
getAttribute: attr
+ Into: s + objectMemory baseHeaderSize
- Into: s + BaseHeaderSize
Length: sz.
self pop: 2 thenPush: s]!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveImageName (in category 'other primitives') -----
primitiveImageName
"When called with a single string argument, record the string as the current image file name. When called with zero arguments, return a string containing the current image file name."
| s sz sCRIfn okToRename |
<var: #sCRIfn type: 'void *'>
argumentCount = 1 ifTrue: [
"If the security plugin can be loaded, use it to check for rename permission.
If not, assume it's ok"
sCRIfn := self ioLoadFunction: 'secCanRenameImage' From: 'SecurityPlugin'.
sCRIfn ~= 0 ifTrue:
[okToRename := self cCode: '((sqInt (*)(void))sCRIfn)()'
inSmalltalk: [self dispatchMappedPluginEntry: sCRIfn].
okToRename ifFalse:
[^self primitiveFail]].
s := self stackTop.
self assertClassOf: s is: (objectMemory splObj: ClassByteString).
self successful ifTrue: [
sz := self stSizeOf: s.
+ self imageNamePut: (s + objectMemory baseHeaderSize) Length: sz.
- self imageNamePut: (s + BaseHeaderSize) Length: sz.
self pop: 1. "pop s, leave rcvr on stack"
].
] ifFalse: [
sz := self imageNameSize.
s := objectMemory instantiateClass: (objectMemory splObj: ClassByteString) indexableSize: sz.
+ self imageNameGet: (s + objectMemory baseHeaderSize) Length: sz.
- self imageNameGet: (s + BaseHeaderSize) Length: sz.
self pop: 1. "rcvr"
self push: s.
]!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveObjectPointsTo (in category 'object access primitives') -----
primitiveObjectPointsTo
| rcvr thang lastField |
thang := self stackTop.
rcvr := self stackValue: 1.
(objectMemory isIntegerObject: rcvr) ifTrue:
[^self pop: 2 thenPushBool: false].
lastField := self lastPointerOf: rcvr.
+ objectMemory baseHeaderSize to: lastField by: objectMemory wordSize do:
- BaseHeaderSize to: lastField by: BytesPerWord do:
[:i |
(self longAt: rcvr + i) = thang ifTrue:
[^self pop: 2 thenPushBool: true]].
self pop: 2 thenPushBool: false!
Item was changed:
----- Method: InterpreterPrimitives>>primitiveVMPath (in category 'system control primitives') -----
primitiveVMPath
"Return a string containing the path name of VM's directory."
| s sz |
sz := self vmPathSize.
s := objectMemory instantiateClass: (objectMemory splObj: ClassByteString) indexableSize: sz.
+ self vmPathGet: (s + objectMemory baseHeaderSize) Length: sz.
- self vmPathGet: (s + BaseHeaderSize) Length: sz.
self pop: 1 thenPush: s.
!
Item was changed:
----- Method: InterpreterPrimitives>>sizeFieldOfAlien: (in category 'primitive support') -----
sizeFieldOfAlien: alienObj
"Answer the first field of alienObj which is assumed to be an Alien of at least 8 bytes"
<inline: true>
+ ^self longAt: alienObj + objectMemory baseHeaderSize!
- ^self longAt: alienObj + BaseHeaderSize!
Item was changed:
----- Method: InterpreterPrimitives>>startOfAlienData: (in category 'primitive support') -----
startOfAlienData: oop
"Answer the start of the Alien's data or fail if oop is not an Alien."
<api>
<returnTypeC: #'void *'>
(self is: oop KindOfClass: (objectMemory splObj: ClassAlien)) ifFalse:
[self primitiveFailFor: PrimErrBadArgument.
^0].
^self cCoerceSimple: ((self isDirectAlien: oop)
+ ifTrue: [oop + objectMemory baseHeaderSize + objectMemory bytesPerOop]
+ ifFalse: [self longAt: oop + objectMemory baseHeaderSize + objectMemory bytesPerOop])
- ifTrue: [oop + BaseHeaderSize + BytesPerOop]
- ifFalse: [self longAt: oop + BaseHeaderSize + BytesPerOop])
to: #'void *'!
Item was changed:
----- Method: InterpreterSimulator>>clipboardWrite:From:At: (in category 'I/O primitives') -----
clipboardWrite: sz From: actualDataAddress At: ignored
+ Clipboard clipboardText: (self stringOf: actualDataAddress - self baseHeaderSize)!
- Clipboard clipboardText: (self stringOf: actualDataAddress - BaseHeaderSize)!
Item was changed:
----- Method: InterpreterSimulator>>firstIndexableField: (in category 'memory access') -----
firstIndexableField: oop
"NOTE: overridden from ObjectMemory to add coercion to CArray, so please duplicate any changes"
| hdr fmt totalLength fixedFields |
<returnTypeC: #'void *'>
hdr := self baseHeader: oop.
fmt := self formatOfHeader: hdr.
fmt <= 4 ifTrue: "<= 4 pointer"
["pointer; may need to delve into the class format word"
totalLength := self lengthOf: oop baseHeader: hdr format: fmt.
fixedFields := self fixedFieldsOf: oop format: fmt length: totalLength.
+ ^self cCoerce: (self pointerForOop: oop + self baseHeaderSize + (fixedFields << self shiftForWord)) to: 'oop *'].
- ^self cCoerce: (self pointerForOop: oop + BaseHeaderSize + (fixedFields << ShiftForWord)) to: 'oop *'].
^self
+ cCoerce: (self pointerForOop: oop + self baseHeaderSize)
- cCoerce: (self pointerForOop: oop + BaseHeaderSize)
to: (fmt < 8
ifTrue: [fmt = 6
ifTrue: ["32 bit field objects" 'int *']
ifFalse: ["full word objects (bits)" 'oop *']]
ifFalse: ["byte objects (including CompiledMethod" 'char *'])!
Item was changed:
----- Method: InterpreterSimulator>>longPrint: (in category 'debug support') -----
longPrint: oop
| lastPtr val lastLong hdrType prevVal |
(self isIntegerObject: oop) ifTrue: [^ self shortPrint: oop].
^ String streamContents:
[:strm |
+ lastPtr := 64*self wordSize min: (self lastPointerOf: oop).
- lastPtr := 64*BytesPerWord min: (self lastPointerOf: oop).
hdrType := self headerType: oop.
hdrType = 2 ifTrue: [lastPtr := 0].
prevVal := 0.
+ (self headerStart: oop) to: lastPtr by: self wordSize do:
- (self headerStart: oop) to: lastPtr by: BytesPerWord do:
[:a | val := self longAt: oop+a.
(a > 0 and: [(val = prevVal) & (a ~= lastPtr)])
ifTrue:
+ [prevVal = (self longAt: oop+a-(self wordSize*2)) ifFalse: [strm cr; nextPutAll: ' ...etc...']]
- [prevVal = (self longAt: oop+a-(BytesPerWord*2)) ifFalse: [strm cr; nextPutAll: ' ...etc...']]
ifFalse:
[strm cr; nextPutAll: (a<16 ifTrue: [' ', a hex] ifFalse: [a hex]);
space; space; space; nextPutAll: val hex8; space; space.
+ a = (self wordSize*2) negated ifTrue:
- a = (BytesPerWord*2) negated ifTrue:
[strm nextPutAll: 'size = ' , (val - hdrType) hex].
+ a = self wordSize negated ifTrue:
- a = BytesPerWord negated ifTrue:
[strm nextPutAll: '<' , (self nameOfClass: (val - hdrType)) , '>'].
a = 0 ifTrue: [strm cr; tab; nextPutAll: (self dumpHeader: val)].
a > 0 ifTrue: [strm nextPutAll: (self shortPrint: val)].
+ a = self wordSize ifTrue:
- a = BytesPerWord ifTrue:
[(self isCompiledMethod: oop) ifTrue:
[strm cr; tab; nextPutAll: (self dumpMethodHeader: val)]]].
prevVal := val].
+ lastLong := 256 min: (self sizeBitsOf: oop) - self baseHeaderSize.
- lastLong := 256 min: (self sizeBitsOf: oop) - BaseHeaderSize.
hdrType = 2
ifTrue:
["free" strm cr; nextPutAll: (oop+(self longAt: oop)-2) hex;
space; space; nextPutAll: (oop+(self longAt: oop)-2) printString]
ifFalse:
[(self formatOf: oop) = 3
ifTrue:
[strm cr; tab; nextPutAll: '/ next 3 fields are above SP... /'.
+ lastPtr+self wordSize to: lastPtr+(3*self wordSize) by: self wordSize do:
- lastPtr+BytesPerWord to: lastPtr+(3*BytesPerWord) by: BytesPerWord do:
[:a | val := self longAt: oop+a.
strm cr; nextPutAll: a hex;
space; space; space; nextPutAll: val hex8; space; space.
(self validOop: val) ifTrue: [strm nextPutAll: (self shortPrint: val)]]]
ifFalse:
+ [lastPtr+self wordSize to: lastLong by: self wordSize do:
- [lastPtr+BytesPerWord to: lastLong by: BytesPerWord do:
[:a | val := self longAt: oop+a.
strm cr; nextPutAll: (a<16 ifTrue: [' ', a hex] ifFalse: [a hex]);
space; space; space.
strm nextPutAll: val hex8; space; space;
nextPutAll: (self charsOfLong: val)]]].
]!
Item was changed:
----- Method: InterpreterSimulator>>nameOfClass: (in category 'debug support') -----
nameOfClass: classOop
+ (self sizeBitsOf: classOop) = (Metaclass instSize +1*self wordSize) ifTrue:
- (self sizeBitsOf: classOop) = (Metaclass instSize +1*BytesPerWord) ifTrue:
[^ (self nameOfClass:
(self fetchPointer: 5 "thisClass" ofObject: classOop)) , ' class'].
^ self stringOf: (self fetchPointer: 6 "name" ofObject: classOop)!
Item was changed:
----- Method: InterpreterSimulator>>printStackTemps:onStream: (in category 'debug support') -----
printStackTemps: ctxt onStream: strm
| home cMethod nArgs nTemps oop |
home := (self fetchClassOf: ctxt) = (self splObj: ClassBlockContext)
ifTrue: [self fetchPointer: HomeIndex ofObject: ctxt]
ifFalse: [ctxt].
cMethod := self fetchPointer: MethodIndex ofObject: home.
nArgs := nTemps := 0.
home = ctxt ifTrue:
[strm cr; tab; nextPutAll: 'args: '.
nArgs := self argumentCountOf: cMethod.
1 to: nArgs do:
[:i | oop := self fetchPointer: TempFrameStart + i-1 ofObject: ctxt.
strm nextPutAll: oop hex; space].
strm cr; tab; nextPutAll: 'temps: '.
nTemps := self tempCountOf: cMethod.
nArgs+1 to: nTemps do:
[:i | oop := self fetchPointer: TempFrameStart + i-1 ofObject: ctxt.
strm nextPutAll: oop hex; space]].
strm cr; tab; nextPutAll: 'stack: '.
+ nTemps + 1 to: (self lastPointerOf: ctxt)//self wordSize - TempFrameStart do:
- nTemps + 1 to: (self lastPointerOf: ctxt)//BytesPerWord - TempFrameStart do:
[:i | oop := self fetchPointer: TempFrameStart + i-1 ofObject: ctxt.
strm nextPutAll: oop hex; space].
!
Item was changed:
----- Method: InterpreterSimulator>>printTop: (in category 'debug support') -----
printTop: n
"Print important fields of the top n contexts"
| ctxt classAndSel home top ip sp |
ctxt := activeContext.
^ String streamContents:
[:strm | 1 to: n do:
[:i |
home := (self fetchClassOf: ctxt) = (self splObj: ClassBlockContext)
ifTrue: [self fetchPointer: HomeIndex ofObject: ctxt]
ifFalse: [ctxt].
classAndSel := self
classAndSelectorOfMethod: (self fetchPointer: MethodIndex ofObject: home)
forReceiver: (self fetchPointer: ReceiverIndex ofObject: home).
strm cr; nextPutAll: ctxt hex8.
ctxt = home ifFalse: [strm nextPutAll: ' [] in'].
strm space; nextPutAll: (self nameOfClass: classAndSel first).
strm nextPutAll: '>>'; nextPutAll: (self shortPrint: classAndSel last).
ctxt = activeContext
+ ifTrue: [ip := instructionPointer - method - (self baseHeaderSize - 2).
- ifTrue: [ip := instructionPointer - method - (BaseHeaderSize - 2).
sp := self stackPointerIndex - TempFrameStart + 1.
top := self stackTop]
ifFalse: [ip := self integerValueOf:
(self fetchPointer: InstructionPointerIndex ofObject: ctxt).
sp := self integerValueOf:
(self fetchPointer: StackPointerIndex ofObject: ctxt).
top := self longAt: ctxt + (self lastPointerOf: ctxt)].
strm cr; tab; nextPutAll: 'ip = '; print: ip.
strm cr; tab; nextPutAll: 'sp = '; print: sp.
strm cr; tab; nextPutAll: 'top = '; nextPutAll: (self shortPrint: top).
(ctxt := (self fetchPointer: SenderIndex ofObject: ctxt)) = nilObj
ifTrue: [^strm contents].
].
]!
Item was changed:
----- Method: InterpreterSimulator>>shortPrint: (in category 'debug support') -----
shortPrint: oop
| name classOop |
(self isIntegerObject: oop) ifTrue: [^ '=' , (self integerValueOf: oop) printString ,
' (' , (self integerValueOf: oop) hex , ')'].
classOop := self fetchClassOf: oop.
+ (self sizeBitsOf: classOop) = (Metaclass instSize +1*self wordSize) ifTrue: [
- (self sizeBitsOf: classOop) = (Metaclass instSize +1*BytesPerWord) ifTrue: [
^ 'class ' , (self nameOfClass: oop)].
name := self nameOfClass: classOop.
name size = 0 ifTrue: [name := '??'].
name = 'String' ifTrue: [^ (self stringOf: oop) printString].
name = 'ByteString' ifTrue: [^ (self stringOf: oop) printString].
name = 'Symbol' ifTrue: [^ '#' , (self stringOf: oop)].
name = 'ByteSymbol' ifTrue: [^ '#' , (self stringOf: oop)].
name = 'Character' ifTrue: [^ '=' , (Character value: (self integerValueOf:
(self fetchPointer: 0 ofObject: oop))) printString].
name = 'UndefinedObject' ifTrue: [^ 'nil'].
name = 'False' ifTrue: [^ 'false'].
name = 'True' ifTrue: [^ 'true'].
name = 'Float' ifTrue: [successFlag := true. ^ '=' , (self floatValueOf: oop) printString].
name = 'Association' ifTrue: [^ '(' ,
+ (self shortPrint: (self longAt: oop + self baseHeaderSize)) ,
- (self shortPrint: (self longAt: oop + BaseHeaderSize)) ,
' -> ' ,
+ (self longAt: oop + self baseHeaderSize + self wordSize) hex8 , ')'].
- (self longAt: oop + BaseHeaderSize + BytesPerWord) hex8 , ')'].
('AEIOU' includes: name first)
ifTrue: [^ 'an ' , name]
ifFalse: [^ 'a ' , name]!
Item was changed:
----- Method: InterpreterSimulator>>stats (in category 'testing') -----
stats
| oop fieldAddr fieldOop last stats v d |
stats := Bag new.
oop := self firstObject.
'Scanning the image...' displayProgressAt: Sensor cursorPoint
from: oop to: endOfMemory
during: [:bar |
[oop < endOfMemory] whileTrue:
[(self isFreeObject: oop) ifFalse:
[stats add: #objects.
fieldAddr := oop + (self lastPointerOf: oop).
[fieldAddr > oop] whileTrue:
[fieldOop := self longAt: fieldAddr.
(self isIntegerObject: fieldOop)
ifTrue: [v := self integerValueOf: fieldOop.
(v between: -16000 and: 16000)
ifTrue: [stats add: #ints32k]
ifFalse: [stats add: #intsOther]]
ifFalse: [fieldOop = nilObj ifTrue: [stats add: #nil]
ifFalse:
[d := fieldOop - oop.
(d between: -16000 and: 16000)
ifTrue: [stats add: #oops32k]
ifFalse: [stats add: #oopsOther]]].
+ fieldAddr := fieldAddr - self wordSize]].
- fieldAddr := fieldAddr - BytesPerWord]].
bar value: oop.
last := oop.
last := last.
oop := self objectAfter: oop]].
^ stats sortedElements!
Item was changed:
----- Method: InterpreterSimulator>>stringOf: (in category 'debug support') -----
stringOf: oop
| size long nLongs chars |
^ String streamContents:
[:strm |
size := 100 min: (self stSizeOf: oop).
+ nLongs := size-1//self wordSize+1.
- nLongs := size-1//BytesPerWord+1.
1 to: nLongs do:
+ [:i | long := self longAt: oop + self baseHeaderSize + (i-1*self wordSize).
- [:i | long := self longAt: oop + BaseHeaderSize + (i-1*BytesPerWord).
chars := self charsOfLong: long.
strm nextPutAll: (i=nLongs
+ ifTrue: [chars copyFrom: 1 to: size-1\\self wordSize+1]
- ifTrue: [chars copyFrom: 1 to: size-1\\BytesPerWord+1]
ifFalse: [chars])]]!
Item was changed:
----- Method: InterpreterSimulator>>validateOopsIn: (in category 'testing') -----
validateOopsIn: object
| fieldPtr limit former header |
"for each oop in me see if it is legal"
+ fieldPtr := object + self baseHeaderSize. "first field"
- fieldPtr := object + BaseHeaderSize. "first field"
limit := object + (self lastPointerOf: object). "a good field"
[fieldPtr > limit] whileFalse: [
former := self longAt: fieldPtr.
(self validOop: former) ifFalse: [self error: 'invalid oop in pointers object'].
+ fieldPtr := fieldPtr + self wordSize].
- fieldPtr := fieldPtr + BytesPerWord].
"class"
header := self baseHeader: object.
(header bitAnd: CompactClassMask) = 0 ifTrue: [
former := (self classHeader: object) bitAnd: AllButTypeMask.
(self validOop: former) ifFalse: [self halt]].!
Item was changed:
----- Method: InterpreterSimulator>>vmPathGet:Length: (in category 'file primitives') -----
vmPathGet: stringBase Length: stringSize
| pathName stringOop |
pathName := Smalltalk vmPath.
+ stringOop := stringBase - self baseHeaderSize. "Due to C call in Interp"
- stringOop := stringBase - BaseHeaderSize. "Due to C call in Interp"
1 to: stringSize do:
[:i | self storeByte: i-1 ofObject: stringOop
withValue: (pathName at: i) asciiValue].
!
Item was changed:
----- Method: InterpreterSimulator>>writeImageFileIO: (in category 'image save/restore') -----
writeImageFileIO: numberOfBytesToWrite
"Actually emit the first numberOfBytesToWrite object memory bytes onto the snapshot."
| headerSize file |
+ self wordSize = 4 ifFalse: [self error: 'Not rewritten for 64 bits yet'].
- 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.
self startOfMemory.
specialObjectsOop.
lastHash.
self ioScreenSize.
fullScreenFlag.
extraVMMemory
}
do: [:long | self putLong: long toFile: file].
"Pad the rest of the header."
7 timesRepeat: [self putLong: 0 toFile: file].
"Position the file after the header."
file position: headerSize.
"Write the object memory."
1
to: numberOfBytesToWrite // 4
do: [:index |
self
putLong: (memory at: index)
toFile: file].
self success: true
]
ensure: [file close]!
Item was changed:
----- Method: InterpreterSimulatorLSB>>nextLongFrom: (in category 'initialization') -----
nextLongFrom: aStream
"Read a 32- or 64-bit quantity from the given (binary) stream."
+ ^ aStream nextLittleEndianNumber: self wordSize!
- ^ aStream nextLittleEndianNumber: BytesPerWord!
Item was changed:
----- Method: InterpreterSimulatorMSB>>byteAt: (in category 'memory access') -----
byteAt: byteAddress
| lowBits bpwMinus1 |
+ bpwMinus1 := self wordSize-1.
- bpwMinus1 := BytesPerWord-1.
lowBits := byteAddress bitAnd: bpwMinus1.
^ ((self longAt: byteAddress - lowBits)
bitShift: (lowBits - bpwMinus1) * 8)
bitAnd: 16rFF!
Item was changed:
----- Method: InterpreterSimulatorMSB>>byteAt:put: (in category 'memory access') -----
byteAt: byteAddress put: byte
| longWord shift lowBits bpwMinus1 longAddress |
+ bpwMinus1 := self wordSize-1.
- bpwMinus1 := BytesPerWord-1.
lowBits := byteAddress bitAnd: bpwMinus1.
longAddress := byteAddress - lowBits.
longWord := self longAt: longAddress.
shift := (bpwMinus1 - lowBits) * 8.
longWord := longWord
- (longWord bitAnd: (16rFF bitShift: shift))
+ (byte bitShift: shift).
self longAt: longAddress put: longWord.
^byte!
Item was changed:
----- Method: InterpreterSimulatorMSB>>charsOfLong: (in category 'debug support') -----
charsOfLong: long
+ ^ (self wordSize to: 1 by: -1) collect:
- ^ (BytesPerWord to: 1 by: -1) collect:
[:i | ((long digitAt: i) between: 14 and: 126)
ifTrue: [(long digitAt: i) asCharacter]
ifFalse: [$?]]!
Item was changed:
----- Method: InterpreterSimulatorMSB>>nextLongFrom: (in category 'initialization') -----
nextLongFrom: aStream
"Read a 32- or 64-bit quantity from the given (binary) stream."
+ ^ aStream nextNumber: self wordSize!
- ^ aStream nextNumber: BytesPerWord!
Item was changed:
----- Method: InterpreterSimulatorMSB>>shortAt: (in category 'memory access') -----
shortAt: byteAddress
"Return the half-word at byteAddress which must be even."
| lowBits bpwMinus2 |
+ bpwMinus2 := self wordSize-2.
- bpwMinus2 := BytesPerWord-2.
lowBits := byteAddress bitAnd: bpwMinus2.
^ ((self longAt: byteAddress - lowBits)
bitShift: (lowBits - bpwMinus2) * 8)
bitAnd: 16rFFFF
!
Item was changed:
----- Method: InterpreterSimulatorMSB>>shortAt:put: (in category 'memory access') -----
shortAt: byteAddress put: a16BitValue
"Return the half-word at byteAddress which must be even."
| longWord shift lowBits bpwMinus2 longAddress |
+ bpwMinus2 := self wordSize-2.
- bpwMinus2 := BytesPerWord-2.
lowBits := byteAddress bitAnd: bpwMinus2.
longAddress := byteAddress - lowBits.
longWord := self longAt: longAddress.
shift := (bpwMinus2 - lowBits) * 8.
longWord := longWord
- (longWord bitAnd: (16rFFFF bitShift: shift))
+ (a16BitValue bitShift: shift).
self longAt: longAddress put: longWord
!
Item was changed:
----- Method: InterpreterStackPage>>headFP: (in category 'accessing') -----
headFP: pointer "<Integer>"
"Set the value of headFP"
- "N.B. This assert is run in simulation only because headFP:
- becomes a simple field assignment in the C code."
- self assert: (pointer = 0 or: [pointer < baseAddress and: [realStackLimit - (LargeContextSize / 2) <= pointer]]).
^headFP := pointer!
Item was changed:
----- Method: InterpreterStackPage>>headSP: (in category 'accessing') -----
headSP: pointer "<Integer>"
"Set the value of headSP"
- "N.B. This assert is run in simulation only because headFP:
- becomes a simple field assignment in the C code."
- self assert: (pointer = 0 or: [pointer < baseAddress and: [realStackLimit - LargeContextSize <= pointer]]).
^headSP := pointer!
Item was changed:
VMClass subclass: #InterpreterStackPages
+ instanceVariableNames: 'interpreter objectMemory stackMemory indexOffset pages mostRecentlyUsedPage overflowLimit numPages pageSizeInSlots bytesPerPage'
- instanceVariableNames: 'interpreter stackMemory indexOffset pages mostRecentlyUsedPage overflowLimit numPages pageSizeInSlots bytesPerPage'
classVariableNames: ''
poolDictionaries: 'VMBasicConstants'
category: 'VMMaker-Interpreter'!
!InterpreterStackPages commentStamp: '<historical>' prior: 0!
I am a class that helps organize the StackInterpreter's collection of stack pages. I hold the set of stack pages represented by InterpreterStackPage instances/StackPage structs. The pages are held in a doubly-linked list that notionally has two heads:
mostRecentlyUsedPage-->used page<->used page<->used page<->used page<--leastRecentlyUsedPage
^ <-next-prev-> ^
| |
v <-prev-next-> v
free page<->free page<->free page<->free page
In fact we don't need the least-recently-used page, and so it is only present conceptually. The point is that there is a possibly empty but contiguous sequence of free pages starting at mostRecentlyUsedPage nextPage. New pages are allocated preferentially from the free page next to the MRUP.
If there are no free pages then (effectively) the LRUP's frames are flushed to contexts and it is used instead.!
Item was changed:
----- Method: InterpreterStackPages>>couldBeFramePointer: (in category 'assertions') -----
couldBeFramePointer: pointer
"Answer if the argument is a properly aligned pointer into the stack zone."
<var: #pointer type: #'void *'>
^self
cCode:
+ [(pointer asUnsignedInteger bitAnd: objectMemory wordSize - 1) = 0
- [(pointer asUnsignedInteger bitAnd: BytesPerWord - 1) = 0
and: [pointer asUnsignedInteger
between: stackMemory asUnsignedInteger
and: pages asUnsignedInteger]]
inSmalltalk:
+ [(pointer bitAnd: objectMemory wordSize - 1) = 0
- [(pointer bitAnd: BytesPerWord - 1) = 0
and: [(self memIndexFor: pointer)
between: 1 and: stackMemory size]]!
Item was changed:
----- Method: InterpreterStackPages>>initializeStack:numSlots:pageSize: (in category 'initialization') -----
initializeStack: theStackPages numSlots: stackSlots pageSize: slotsPerPage
"Initialize the stack pages. For testing I want stack addresses to be disjoint from
normal memory addresses so stack addresses are negative. The first address is
-pageSize bytes. So for example if there are 1024 bytes per page and 3 pages
then the pages are organized as
byte address: -1024 <-> -2047 | -2048 <-> -3071 | -3072 <-> -4096 |
page 3 page 2 page 1
mem index: 769 <-> 513 | 512 <-> 257 | 256 <-> 1 |
The byte address is the external address corresponding to a real address in the VM.
mem index is the index in the memory Array holding the stack, an index internal to
the stack pages. The first stack page allocated will be the last page in the array of pages
at the highest effective address. Its base address be -1024 and grow down towards -2047."
"The lFoo's are to get around the foo->variable scheme in the C call to allocStackPages below."
<var: #theStackPages type: #'char *'>
| page structStackPageSize pageStructBase count |
<var: #page type: #'StackPage *'>
<var: #pageStructBase type: #'char *'>
self cCode: ''
inSmalltalk:
[self assert: stackMemory size = stackSlots.
self assert: stackMemory == theStackPages].
stackMemory := theStackPages. "For initialization in the C code."
self cCode: '' inSmalltalk: [pageSizeInSlots := slotsPerPage].
structStackPageSize := interpreter sizeof: InterpreterStackPage.
+ bytesPerPage := slotsPerPage * objectMemory wordSize.
+ numPages := stackSlots // (slotsPerPage + (structStackPageSize / objectMemory wordSize)).
- bytesPerPage := slotsPerPage * BytesPerWord.
- numPages := stackSlots // (slotsPerPage + (structStackPageSize / BytesPerWord)).
"Because stack pages grow down baseAddress is at the top of a stack page and so to avoid
subtracting BytesPerWord from baseAddress and lastAddress in the init loop below we simply
push the stackPage array up one word to avoid the overlap. This word is extraStackBytes."
+ pageStructBase := theStackPages + (numPages * bytesPerPage) + objectMemory wordSize.
- pageStructBase := theStackPages + (numPages * bytesPerPage) + BytesPerWord.
pages := self cCode: '(StackPage *)pageStructBase'
inSmalltalk:
[pageStructBase class.
(1 to: numPages) collect: [:i| InterpreterStackPage new]].
"Simulation only. Since addresses are negative the offset is positive. To make all
stack addresses negative we make the offset a page more than it needs to be so the
address of the last slot in memory (the highest address in the stack, or its start) is
- pageByteSize
and the address of the first slot (the lowest address, or its end) is
- pageByteSize * (numPages + 1)"
self cCode: '' inSmalltalk: [indexOffset := (numPages + 1) * slotsPerPage].
"make sure there's enough headroom"
self assert: interpreter stackPageByteSize - interpreter stackLimitBytes - interpreter stackLimitOffset
>= interpreter stackPageHeadroom.
0 to: numPages - 1 do:
[:index|
page := self stackPageAt: index.
page
lastAddress: (self cCode: '(char *)theStackPages + (index * GIV(bytesPerPage))'
+ inSmalltalk: [(index * slotsPerPage - indexOffset) * objectMemory wordSize]);
- inSmalltalk: [(index * slotsPerPage - indexOffset) * BytesPerWord]);
baseAddress: (page lastAddress + bytesPerPage);
stackLimit: page baseAddress - interpreter stackLimitBytes;
realStackLimit: page stackLimit;
baseFP: 0;
nextPage: (self stackPageAt: (index = (numPages - 1) ifTrue: [0] ifFalse: [index + 1]));
prevPage: (self stackPageAt: (index = 0 ifTrue: [numPages - 1] ifFalse: [index - 1]))].
self cCode: ''
inSmalltalk:
[| lowestAddress highestAddress |
+ lowestAddress := (pages at: 1) lastAddress + objectMemory wordSize.
- lowestAddress := (pages at: 1) lastAddress + BytesPerWord.
highestAddress := (pages at: numPages) baseAddress.
"see InterpreterStackPages>>longAt:"
+ self assert: lowestAddress // objectMemory wordSize + indexOffset = 1.
+ self assert: highestAddress // objectMemory wordSize + indexOffset = (numPages * slotsPerPage)].
- self assert: lowestAddress // BytesPerWord + indexOffset = 1.
- self assert: highestAddress // BytesPerWord + indexOffset = (numPages * slotsPerPage)].
"The overflow limit is the amount of stack to retain when moving frames from an overflowing
stack to reduce thrashing. See stackOverflowOrEvent:mayContextSwitch:"
page := self stackPageAt: 0.
overflowLimit := page baseAddress - page realStackLimit * 3 // 5.
0 to: numPages - 1 do:
[:index|
page := self stackPageAt: index.
self assert: (self pageIndexFor: page baseAddress) == index.
+ self assert: (self pageIndexFor: page baseAddress - (slotsPerPage - 1 * objectMemory wordSize)) == index.
- self assert: (self pageIndexFor: page baseAddress - (slotsPerPage - 1 * BytesPerWord)) == index.
self assert: (self stackPageFor: page baseAddress) == page.
self assert: (self stackPageFor: page stackLimit) == page.
self cCode: ''
inSmalltalk:
[| memIndex |
memIndex := index * slotsPerPage + 1. "this is memIndex in the block above"
self assert: (self memIndexFor: (self oopForPointer: page baseAddress))
== (memIndex + slotsPerPage - 1).
index < (numPages - 1) ifTrue:
+ [self assert: (self stackPageFor: page baseAddress + objectMemory wordSize) == (self stackPageAt: index + 1)]].
- [self assert: (self stackPageFor: page baseAddress + BytesPerWord) == (self stackPageAt: index + 1)]].
interpreter initializePageTraceToInvalid: page].
mostRecentlyUsedPage := self stackPageAt: 0.
page := mostRecentlyUsedPage.
count := 0.
[| theIndex |
count := count + 1.
theIndex := self pageIndexFor: page baseAddress.
self assert: (self stackPageAt: theIndex) == page.
self assert: (self pageIndexFor: page baseAddress) == theIndex.
self assert: (self pageIndexFor: page stackLimit) == theIndex.
+ self assert: (self pageIndexFor: page lastAddress + objectMemory wordSize) == theIndex.
- self assert: (self pageIndexFor: page lastAddress + BytesPerWord) == theIndex.
(page := page nextPage) ~= mostRecentlyUsedPage] whileTrue.
self assert: count == numPages.
self assert: self pageListIsWellFormed!
Item was changed:
----- Method: InterpreterStackPages>>initializeWithByteSize:for: (in category 'initialization') -----
initializeWithByteSize: byteSize "<Integer>" for: anInterpreter "<StackInterpreter>" "^<Array of: <Integer>"
"Initialize the stackPages memory for simulation."
<doNotGenerate>
interpreter := anInterpreter.
+ objectMemory := anInterpreter objectMemory.
+ ^stackMemory := Array new: byteSize / objectMemory wordSize withAll: 0!
- ^stackMemory := Array new: byteSize / BytesPerWord withAll: 0!
Item was changed:
----- Method: InterpreterStackPages>>longAt: (in category 'memory access') -----
longAt: byteAddress
+ <doNotGenerate>
"Note: Adjusted for Smalltalk's 1-based array indexing."
+ self assert: (byteAddress bitAnd: objectMemory wordSize - 1) == 0.
+ ^stackMemory at: byteAddress // objectMemory wordSize + indexOffset!
- self assert: (byteAddress bitAnd: BytesPerWord - 1) == 0.
- ^stackMemory at: byteAddress // BytesPerWord + indexOffset!
Item was changed:
----- Method: InterpreterStackPages>>longAt:put: (in category 'memory access') -----
longAt: byteAddress put: a32BitValue
+ <doNotGenerate>
"Note: Adjusted for Smalltalk's 1-based array indexing."
+ self assert: (byteAddress bitAnd: objectMemory wordSize - 1) == 0.
+ ^stackMemory at: byteAddress // objectMemory wordSize + indexOffset put: a32BitValue!
- self assert: (byteAddress bitAnd: BytesPerWord - 1) == 0.
- ^stackMemory at: byteAddress // BytesPerWord + indexOffset put: a32BitValue!
Item was changed:
----- Method: InterpreterStackPages>>markStackPageMostRecentlyUsed: (in category 'page access') -----
markStackPageMostRecentlyUsed: page "<InterpreterStackPage>"
"MRUP-->used page<->used page<->used page<->used page<--LRUP
^ <-next-prev-> ^
| |
v <-prev-next-> v
free page<->free page<->free page<->free page"
<var: #page type: #'StackPage *'>
- <asmLabel: false>
page == mostRecentlyUsedPage ifTrue:
[^nil].
"Common case; making new page most recently used."
page prevPage == mostRecentlyUsedPage ifTrue:
[mostRecentlyUsedPage := page.
self assert: self pageListIsWellFormed.
^nil].
page prevPage nextPage: page nextPage.
page nextPage prevPage: page prevPage.
mostRecentlyUsedPage nextPage prevPage: page.
page prevPage: mostRecentlyUsedPage.
page nextPage: mostRecentlyUsedPage nextPage.
mostRecentlyUsedPage nextPage: page.
mostRecentlyUsedPage := page.
self assert: self pageListIsWellFormed!
Item was changed:
----- Method: InterpreterStackPages>>memIndexFor: (in category 'page access') -----
memIndexFor: byteAddress
+ ^(self oopForPointer: byteAddress) // objectMemory wordSize + indexOffset!
- ^(self oopForPointer: byteAddress) // BytesPerWord + indexOffset!
Item was added:
+ ----- Method: InterpreterStackPages>>setInterpreter: (in category 'initialization') -----
+ setInterpreter: anInterpreter
+ "Initialize the stackPages memory for simulation."
+ <doNotGenerate>
+ interpreter := anInterpreter.
+ objectMemory := interpreter objectMemory!
Item was changed:
----- Method: NewCoObjectMemory>>copyObj:toSegment:addr:stopAt:saveOopAt:headerAt: (in category 'image segment in/out') -----
copyObj: oop toSegment: segmentWordArray addr: lastSeg stopAt: stopAddr saveOopAt: oopPtr headerAt: hdrPtr
"Copy this object into the segment beginning at lastSeg.
Install a forwarding pointer, and save oop and header.
Fail if out of space. Return the next segmentAddr if successful."
"Copy the object..."
| extraSize bodySize hdrAddr |
<inline: false>
self flag: #Dan. "None of the imageSegment stuff has been updated for 64 bits"
extraSize := self extraHeaderBytes: oop.
bodySize := self sizeBitsOf: oop.
(self oop: (lastSeg + extraSize + bodySize) isGreaterThanOrEqualTo: stopAddr) ifTrue:
[^0]. "failure"
+ self transfer: extraSize + bodySize // self wordSize "wordCount"
- self transfer: extraSize + bodySize // BytesPerWord "wordCount"
from: oop - extraSize
+ to: lastSeg+self wordSize.
- to: lastSeg+BytesPerWord.
"Clear root and mark bits of all headers copied into the segment"
+ hdrAddr := lastSeg+self wordSize + extraSize.
- hdrAddr := lastSeg+BytesPerWord + extraSize.
self longAt: hdrAddr put: ((self longAt: hdrAddr) bitAnd: AllButRootBit - MarkBit).
"Make sure Cogged methods have their true header field written to the segment."
((self isCompiledMethod: oop)
and: [coInterpreter methodHasCogMethod: oop]) ifTrue:
+ [self longAt: hdrAddr+self baseHeaderSize put: (self methodHeaderOf: oop)].
- [self longAt: hdrAddr+BaseHeaderSize put: (self methodHeaderOf: oop)].
+ self forward: oop to: (lastSeg+self wordSize + extraSize - segmentWordArray)
- self forward: oop to: (lastSeg+BytesPerWord + extraSize - segmentWordArray)
savingOopAt: oopPtr
andHeaderAt: hdrPtr.
"Return new end of segment"
^lastSeg + extraSize + bodySize!
Item was changed:
----- Method: NewCoObjectMemory>>validate: (in category 'simulation') -----
validate: oop
<doNotGenerate>
| header type cc sz fmt nextChunk |
header := self longAt: oop.
type := header bitAnd: 3.
type = 2 ifFalse: [type = (self rightType: header) ifFalse: [self halt]].
sz := (header bitAnd: SizeMask) >> 2.
nextChunk := oop + ((self isFreeObject: oop)
ifTrue: [self sizeOfFree: oop]
ifFalse: [self sizeBitsOf: oop]).
nextChunk >= freeStart
ifTrue:
[nextChunk ~= freeStart ifTrue: [self halt]]
ifFalse:
[(self headerType: nextChunk) = 0 ifTrue:
+ [(self headerType: (nextChunk + (self wordSize*2))) = 0 ifFalse: [self halt]].
- [(self headerType: (nextChunk + (BytesPerWord*2))) = 0 ifFalse: [self halt]].
(self headerType: nextChunk) = 1 ifTrue:
+ [(self headerType: (nextChunk + self wordSize)) = 1 ifFalse: [self halt]]].
- [(self headerType: (nextChunk + BytesPerWord)) = 1 ifFalse: [self halt]]].
type = 2 ifTrue: "free block"
[^self].
fmt := self formatOfHeader: header.
cc := self compactClassIndexOfHeader: header.
cc > 16 ifTrue: [self halt]. "up to 32 are legal, but not used"
type = 0 ifTrue:
["three-word header"
+ ((self longAt: oop-self wordSize) bitAnd: 3) = type ifFalse: [self halt].
+ ((self longAt: oop-(self wordSize*2)) bitAnd: 3) = type ifFalse: [self halt].
+ ((self longAt: oop-self wordSize) = type) ifTrue: [self halt]. "Class word is 0"
- ((self longAt: oop-BytesPerWord) bitAnd: 3) = type ifFalse: [self halt].
- ((self longAt: oop-(BytesPerWord*2)) bitAnd: 3) = type ifFalse: [self halt].
- ((self longAt: oop-BytesPerWord) = type) ifTrue: [self halt]. "Class word is 0"
sz = 0 ifFalse: [self halt]].
type = 1 ifTrue:
["two-word header"
+ ((self longAt: oop-self wordSize) bitAnd: 3) = type ifFalse: [self halt].
- ((self longAt: oop-BytesPerWord) bitAnd: 3) = type ifFalse: [self halt].
cc > 0 ifTrue: [sz = 1 ifFalse: [self halt]].
sz = 0 ifTrue: [self halt]].
type = 3 ifTrue:
["one-word header"
cc = 0 ifTrue: [self halt]].
fmt = 5 ifTrue: [self halt].
fmt = 7 ifTrue: [self halt].
fmt >= self firstCompiledMethodFormat ifTrue: "must have integer header or be cog method"
+ [header := self longAt: oop + self wordSize.
- [header := self longAt: oop + BytesPerWord.
((self isIntegerObject: header)
or: [(header bitAnd: 7) = 0
and: [header asUnsignedInteger < self startOfMemory
and: [header asUnsignedInteger >= cogit minCogMethodAddress]]]) ifFalse: [self halt]].!
Item was added:
+ ----- Method: NewCoObjectMemorySimulator>>baseHeaderSize (in category 'memory access') -----
+ baseHeaderSize
+ ^4!
Item was added:
+ ----- Method: NewCoObjectMemorySimulator>>bytesPerOop (in category 'memory access') -----
+ bytesPerOop
+ ^4!
Item was changed:
----- Method: NewCoObjectMemorySimulator>>fetchPointer:ofObject: (in category 'interpreter access') -----
fetchPointer: fieldIndex ofObject: oop
"index by word size, and return a pointer as long as the word size"
self assert: oop >= self startOfMemory.
+ self assert: oop + self baseHeaderSize + (fieldIndex << self shiftForWord) < freeStart.
- self assert: oop + BaseHeaderSize + (fieldIndex << ShiftForWord) < freeStart.
^super fetchPointer: fieldIndex ofObject: oop!
Item was changed:
----- Method: NewCoObjectMemorySimulator>>firstIndexableField: (in category 'simulation only') -----
firstIndexableField: oop
"NOTE: overridden from ObjectMemory to add coercion to CArray, so please duplicate any changes"
| hdr fmt totalLength fixedFields |
<returnTypeC: #'void *'>
hdr := self baseHeader: oop.
fmt := self formatOfHeader: hdr.
fmt <= 4 ifTrue: "<= 4 pointer"
["pointer; may need to delve into the class format word"
totalLength := self lengthOf: oop baseHeader: hdr format: fmt.
fixedFields := self fixedFieldsOf: oop format: fmt length: totalLength.
+ ^self cCoerce: (self pointerForOop: oop + self baseHeaderSize + (fixedFields << self shiftForWord)) to: 'oop *'].
- ^self cCoerce: (self pointerForOop: oop + BaseHeaderSize + (fixedFields << ShiftForWord)) to: 'oop *'].
^self
+ cCoerce: (self pointerForOop: oop + self baseHeaderSize)
- cCoerce: (self pointerForOop: oop + BaseHeaderSize)
to: (fmt < 8
ifTrue: [fmt = 6
ifTrue: ["32 bit field objects" 'int *']
ifFalse: ["full word objects (bits)" 'oop *']]
ifFalse: ["byte objects (including CompiledMethod" 'char *'])!
Item was changed:
----- Method: NewCoObjectMemorySimulator>>storePointer:ofObject:withValue: (in category 'interpreter access') -----
storePointer: fieldIndex ofObject: oop withValue: valuePointer
"Override to ensure acess is within the heap, and within the object"
| fmt hdr |
self assert: oop >= self startOfMemory.
hdr := self baseHeader: oop.
fmt := self formatOfHeader: hdr.
self assert: ((fmt <= 4 or: [fmt >= 12])
and: [fieldIndex >= 0 and: [fieldIndex < (self lengthOf: oop baseHeader: hdr format: fmt)]]).
+ self assert: oop + self baseHeaderSize + (fieldIndex << self shiftForWord) < freeStart.
- self assert: oop + BaseHeaderSize + (fieldIndex << ShiftForWord) < freeStart.
^super storePointer: fieldIndex ofObject: oop withValue: valuePointer!
Item was changed:
----- Method: NewCoObjectMemorySimulator>>storePointerUnchecked:ofObject:withValue: (in category 'interpreter access') -----
storePointerUnchecked: fieldIndex ofObject: oop withValue: valuePointer
"Override to ensure acess is within the heap, and within the object"
| fmt hdr |
self assert: oop >= self startOfMemory.
hdr := self baseHeader: oop.
fmt := self formatOfHeader: hdr.
self assert: ((fmt <= 4 or: [fmt >= 12])
and: [fieldIndex >= 0 and: [fieldIndex < (self lengthOf: oop baseHeader: hdr format: fmt)]]).
+ self assert: oop + self baseHeaderSize + (fieldIndex << self shiftForWord) < freeStart.
- self assert: oop + BaseHeaderSize + (fieldIndex << ShiftForWord) < freeStart.
^super storePointerUnchecked: fieldIndex ofObject: oop withValue: valuePointer!
Item was added:
+ ----- Method: NewCoObjectMemorySimulator>>wordSize (in category 'memory access') -----
+ wordSize
+ ^4!
Item was changed:
----- Method: NewCoObjectMemorySimulatorLSB>>nextLongFrom: (in category 'initialization') -----
nextLongFrom: aStream
"Read a 32- or 64-bit quantity from the given (binary) stream."
+ ^ aStream nextLittleEndianNumber: self wordSize!
- ^ aStream nextLittleEndianNumber: BytesPerWord!
Item was changed:
----- Method: NewCoObjectMemorySimulatorMSB>>byteAt: (in category 'memory access') -----
byteAt: byteAddress
| lowBits bpwMinus1 |
+ bpwMinus1 := self wordSize-1.
- bpwMinus1 := BytesPerWord-1.
lowBits := byteAddress bitAnd: bpwMinus1.
^ ((self longAt: byteAddress - lowBits)
bitShift: (lowBits - bpwMinus1) * 8)
bitAnd: 16rFF!
Item was changed:
----- Method: NewCoObjectMemorySimulatorMSB>>byteAt:put: (in category 'memory access') -----
byteAt: byteAddress put: byte
| longWord shift lowBits bpwMinus1 longAddress |
+ bpwMinus1 := self wordSize-1.
- bpwMinus1 := BytesPerWord-1.
lowBits := byteAddress bitAnd: bpwMinus1.
longAddress := byteAddress - lowBits.
longWord := self longAt: longAddress.
shift := (bpwMinus1 - lowBits) * 8.
longWord := longWord
- (longWord bitAnd: (16rFF bitShift: shift))
+ (byte bitShift: shift).
self assert: longAddress < freeStart.
self longAt: longAddress put: longWord.
^byte!
Item was changed:
----- Method: NewCoObjectMemorySimulatorMSB>>charsOfLong: (in category 'debug support') -----
charsOfLong: long
+ ^ (self wordSize to: 1 by: -1) collect:
- ^ (BytesPerWord to: 1 by: -1) collect:
[:i | ((long digitAt: i) between: 14 and: 126)
ifTrue: [(long digitAt: i) asCharacter]
ifFalse: [$?]]!
Item was changed:
----- Method: NewCoObjectMemorySimulatorMSB>>nextLongFrom: (in category 'image save/restore') -----
nextLongFrom: aStream
"Read a 32- or 64-bit quantity from the given (binary) stream."
+ ^ aStream nextNumber: self wordSize!
- ^ aStream nextNumber: BytesPerWord!
Item was changed:
----- Method: NewCoObjectMemorySimulatorMSB>>shortAt: (in category 'memory access') -----
shortAt: byteAddress
"Return the half-word at byteAddress which must be even."
| lowBits bpwMinus2 |
+ bpwMinus2 := self wordSize-2.
- bpwMinus2 := BytesPerWord-2.
lowBits := byteAddress bitAnd: bpwMinus2.
^ ((self longAt: byteAddress - lowBits)
bitShift: (lowBits - bpwMinus2) * 8)
bitAnd: 16rFFFF
!
Item was changed:
----- Method: NewCoObjectMemorySimulatorMSB>>shortAt:put: (in category 'memory access') -----
shortAt: byteAddress put: a16BitValue
"Return the half-word at byteAddress which must be even."
| longWord shift lowBits bpwMinus2 longAddress |
+ bpwMinus2 := self wordSize-2.
- bpwMinus2 := BytesPerWord-2.
lowBits := byteAddress bitAnd: bpwMinus2.
longAddress := byteAddress - lowBits.
longWord := self longAt: longAddress.
shift := (bpwMinus2 - lowBits) * 8.
longWord := longWord
- (longWord bitAnd: (16rFFFF bitShift: shift))
+ (a16BitValue bitShift: shift).
self longAt: longAddress put: longWord
!
Item was changed:
----- Method: NewObjectMemory>>allInstancesOf: (in category 'primitive support') -----
allInstancesOf: aBehavior
"Attempt to answer all instances of aBehavior, failing if there is not enough room."
| count container fillPointer obj byteSize afterPreAllocatedObject |
"Allocate a large header Array of sufficient size to require a large header.
Reset its size later."
container := self instantiateClass: (self splObj: ClassArray) indexableSize: self minLargeHeaderSize.
self sizeHeader: container putBodySize: 0.
afterPreAllocatedObject := freeStart.
freeStart := fillPointer := (self firstFixedField: container) asInteger.
count := 0.
obj := self firstObject.
[self oop: obj isLessThan: container] whileTrue:
[(self isFreeObject: obj) ifFalse:
[(self fetchClassOfNonImm: obj) = aBehavior ifTrue:
[count := count + 1.
fillPointer < reserveStart ifTrue:
[self longAt: fillPointer put: obj.
+ fillPointer := fillPointer + self bytesPerOop]]].
- fillPointer := fillPointer + BytesPerOop]]].
obj := self accessibleObjectAfter: obj].
fillPointer >= reserveStart ifTrue: "didn't fit. refill with allocation check pattern and answer count."
[self maybeFillWithAllocationCheckFillerFrom: freeStart to: fillPointer.
^self integerObjectOf: count].
byteSize := fillPointer - (self firstFixedField: container) asInteger.
self sizeHeader: container putBodySize: byteSize.
"Need to refill with the allocation check pattern if we shortened the object."
fillPointer < afterPreAllocatedObject ifTrue:
[self maybeFillWithAllocationCheckFillerFrom: fillPointer to: afterPreAllocatedObject].
freeStart := fillPointer.
^container!
Item was changed:
----- Method: NewObjectMemory>>allocate:headerSize:h1:h2:h3:doFill:format: (in category 'allocation') -----
allocate: byteSize headerSize: hdrSize h1: baseHeader h2: classOopArg h3: extendedSize doFill: doFill format: format
"Allocate a new object of the given size and number of header words. (Note: byteSize already includes space for the base header word.) Initialize the header fields of the new object and fill the remainder of the object with a value appropriate for the format.
May cause a GC"
| newObj classOop |
<inline: true>
<var: #i type: #usqInt>
<var: #end type: #usqInt>
+ newObj := self allocateChunk: byteSize + (hdrSize - 1 * self wordSize).
- newObj := self allocateChunk: byteSize + (hdrSize - 1 * BytesPerWord).
newObj = 0
ifTrue:
["remap classOop because GC may move the classOop"
hdrSize > 1 ifTrue: [self pushRemappableOop: classOopArg].
+ newObj := self allocateChunkAfterGC: byteSize + (hdrSize - 1 * self wordSize).
- newObj := self allocateChunkAfterGC: byteSize + (hdrSize - 1 * BytesPerWord).
hdrSize > 1 ifTrue: [classOop := self popRemappableOop].
newObj = 0 ifTrue: [^newObj]]
ifFalse: [classOop := classOopArg].
hdrSize = 3 ifTrue:
[self longAt: newObj put: (extendedSize bitOr: HeaderTypeSizeAndClass).
+ self longAt: newObj + self wordSize put: (classOop bitOr: HeaderTypeSizeAndClass).
+ self longAt: newObj + (self wordSize*2) put: (baseHeader bitOr: HeaderTypeSizeAndClass).
+ newObj := newObj + (self wordSize*2)].
- self longAt: newObj + BytesPerWord put: (classOop bitOr: HeaderTypeSizeAndClass).
- self longAt: newObj + (BytesPerWord*2) put: (baseHeader bitOr: HeaderTypeSizeAndClass).
- newObj := newObj + (BytesPerWord*2)].
hdrSize = 2 ifTrue:
[self longAt: newObj put: (classOop bitOr: HeaderTypeClass).
+ self longAt: newObj + self wordSize put: (baseHeader bitOr: HeaderTypeClass).
+ newObj := newObj + self wordSize].
- self longAt: newObj + BytesPerWord put: (baseHeader bitOr: HeaderTypeClass).
- newObj := newObj + BytesPerWord].
hdrSize = 1 ifTrue:
[self longAt: newObj put: (baseHeader bitOr: HeaderTypeShort)].
"clear new object"
doFill ifTrue:
[| fillWord end i |
fillWord := format <= self lastPointerFormat
ifTrue: [nilObj] "if pointers, fill with nil oop"
ifFalse: [0].
end := newObj + byteSize.
+ i := newObj + self wordSize. "skip header"
- i := newObj + BytesPerWord. "skip header"
[i < end] whileTrue:
[self longAt: i put: fillWord.
+ i := i + self wordSize].
- i := i + BytesPerWord].
self assert: i = freeStart.].
DoExpensiveAssertionChecks ifTrue:
[self okayOop: newObj.
self oopHasOkayClass: newObj.
(self safeObjectAfter: newObj) = freeStart ifFalse:
[self error: 'allocate bug: did not set header of new oop correctly']].
^newObj!
Item was changed:
----- Method: NewObjectMemory>>allocateInterpreterChunk: (in category 'allocation') -----
allocateInterpreterChunk: byteSize
"Allocate a chunk of the given size. Sender must be sure that the requested size
includes enough space for the header word(s). This version is for interpreter
allocations and will allocate beyond the interpreter's reserveStart. If the allocation
takes freeStart over the scavenge threshold schedule a garbage collection."
| newChunk newFreeStart |
<inline: true>
- <asmLabel: false>
<var: #newChunk type: #usqInt>
<var: #newFreeStart type: #usqInt>
newChunk := freeStart.
newFreeStart := freeStart + byteSize.
newFreeStart < scavengeThreshold ifTrue:
[freeStart := newFreeStart.
^self oopForPointer: newChunk].
"Don't thrash doing collections when over the scavengeThreshold.
Only schedule an incrementalGC if this allocation took us over the threshold."
freeStart < scavengeThreshold ifTrue:
[self scheduleIncrementalGC].
newFreeStart < reserveStart ifTrue:
[freeStart := newFreeStart.
^self oopForPointer: newChunk].
"space is low. A scavenge may reclaim sufficient space and this may be a
false alarm. We actually check for low space after the incremental collection.
But we really do need to do a scavenge promptly, if only to check for low
space. We cannot do a garbage collect now without moving pointers under
the VM's feet, which is too error-prone and inefficient to contemplate."
self scheduleIncrementalGC.
freeStart <= endOfMemory ifTrue:
[freeStart := newFreeStart.
^self oopForPointer: newChunk].
self error: 'out of memory'.
^nil!
Item was removed:
- ----- Method: NewObjectMemory>>badContextSize: (in category 'contexts') -----
- badContextSize: oop
- | numSlots |
- numSlots := self numSlotsOf: oop.
- ^numSlots ~= SmallContextSlots and: [numSlots ~= LargeContextSlots]!
Item was changed:
----- Method: NewObjectMemory>>biasToGrow (in category 'garbage collection') -----
biasToGrow
- <asmLabel: false>
self growObjectMemory: (growHeadroom*3/2) - self freeSize!
Item was removed:
- ----- Method: NewObjectMemory>>bytesPerSlot (in category 'accessing') -----
- bytesPerSlot
- ^self bytesPerOop!
Item was changed:
----- Method: NewObjectMemory>>checkHeapIntegrity (in category 'memory access') -----
checkHeapIntegrity
"Perform an integrity/leak check using the heapMap. Assume
clearLeakMapAndMapAccessibleObjects has set a bit at each
object's header. Scan all objects in the heap checking that every
pointer points to a header. Scan the rootTable, remapBuffer and
extraRootTable checking that every entry is a pointer to a header.
Check that the number of roots is correct and that all rootTable
entries have their rootBit set. Answer if all checks pass."
| ok obj sz hdr fmt fi fieldOop numRootsInHeap |
<inline: false>
ok := true.
numRootsInHeap := 0.
obj := self firstObject.
[self oop: obj isLessThan: self startOfFreeSpace] whileTrue:
[(self isFreeObject: obj)
ifTrue:
[sz := self sizeOfFree: obj]
ifFalse:
[hdr := self baseHeader: obj.
(self isYoungRootHeader: hdr) ifTrue:
[numRootsInHeap := numRootsInHeap + 1].
(self compactClassIndexOfHeader: hdr) = 0 ifTrue:
[fieldOop := (self classHeader: obj) bitAnd: AllButTypeMask.
((self isIntegerObject: fieldOop)
or: [(heapMap heapMapAtWord: (self pointerForOop: fieldOop)) = 0]) ifTrue:
[self print: 'object leak in '; printHex: obj; print: ' class = '; printHex: fieldOop; cr.
self eek.
ok := false]].
fmt := self formatOfHeader: hdr.
(fmt <= 4 "pointers" or: [fmt >= 12 "compiled method"]) ifTrue:
[fmt >= 12
ifTrue: [fi := (self literalCountOf: obj) + LiteralStart]
ifFalse: [(fmt = 3 and: [self isContextHeader: hdr])
ifTrue: [fi := CtxtTempFrameStart + (coInterpreter fetchStackPointerOf: obj)]
ifFalse: [fi := self lengthOf: obj]].
[(fi := fi - 1) >= 0] whileTrue:
[fieldOop := self fetchPointer: fi ofObject: obj.
(self isNonIntegerObject: fieldOop) ifTrue:
+ [(fieldOop bitAnd: self wordSize - 1) ~= 0
- [(fieldOop bitAnd: BytesPerWord - 1) ~= 0
ifTrue:
[self print: 'misaligned oop in '; printHex: obj; print: ' @ '; printNum: fi; print: ' = '; printHex: fieldOop; cr.
self eek.
ok := false]
ifFalse:
[(heapMap heapMapAtWord: (self pointerForOop: fieldOop)) = 0 ifTrue:
[self print: 'object leak in '; printHex: obj; print: ' @ '; printNum: fi; print: ' = '; printHex: fieldOop; cr.
self eek.
ok := false]]]]].
sz := self sizeBitsOf: obj].
obj := self oopFromChunk: obj + sz].
numRootsInHeap ~= rootTableCount ifTrue:
[self print: 'root count mismatch. #heap roots '; printNum: numRootsInHeap; print: '; #roots '; printNum: rootTableCount; cr.
"But the system copes with overflow..."
ok := rootTableOverflowed and: [needGCFlag]].
1 to: rootTableCount do:
[:ri|
obj := rootTable at: ri.
+ (obj bitAnd: self wordSize - 1) ~= 0
- (obj bitAnd: BytesPerWord - 1) ~= 0
ifTrue:
[self print: 'misaligned oop in rootTable @ '; printNum: ri; print: ' = '; printHex: obj; cr.
self eek.
ok := false]
ifFalse:
[(heapMap heapMapAtWord: (self pointerForOop: obj)) = 0
ifTrue:
[self print: 'object leak in rootTable @ '; printNum: ri; print: ' = '; printHex: obj; cr.
self eek.
ok := false]
ifFalse:
[hdr := self baseHeader: obj.
(self isYoungRootHeader: hdr) ifFalse:
[self print: 'non-root in rootTable @ '; printNum: ri; print: ' = '; printHex: obj; cr.
self eek.
ok := false]]]].
1 to: remapBufferCount do:
[:ri|
obj := remapBuffer at: ri.
+ (obj bitAnd: self wordSize - 1) ~= 0
- (obj bitAnd: BytesPerWord - 1) ~= 0
ifTrue:
[self print: 'misaligned remapRoot @ '; printNum: ri; print: ' = '; printHex: obj; cr.
self eek.
ok := false]
ifFalse:
[(heapMap heapMapAtWord: (self pointerForOop: obj)) = 0
ifTrue:
[self print: 'object leak in remapRoots @ '; printNum: ri; print: ' = '; printHex: obj; cr.
self eek.
ok := false]]].
1 to: extraRootCount do:
[:ri|
obj := (extraRoots at: ri) at: 0.
+ (obj bitAnd: self wordSize - 1) ~= 0
- (obj bitAnd: BytesPerWord - 1) ~= 0
ifTrue:
[self print: 'misaligned extraRoot @ '; printNum: ri; print: ' => '; printHex: obj; cr.
self eek.
ok := false]
ifFalse:
[(heapMap heapMapAtWord: (self pointerForOop: obj)) = 0
ifTrue:
[self print: 'object leak in extraRoots @ '; printNum: ri; print: ' => '; printHex: obj; cr.
self eek.
ok := false]]].
^ok!
Item was changed:
----- Method: NewObjectMemory>>checkOkayOop: (in category 'debug support') -----
checkOkayOop: oop
"Verify that the given oop is legitimate. Check address, header, and size but not class.
Answer true if OK. Otherwise print reason and answer false."
<api>
<var: #oop type: #usqInt>
| sz type fmt unusedBit |
"address and size checks"
(self isIntegerObject: oop) ifTrue: [ ^true ].
((self oop: oop isGreaterThanOrEqualTo: self startOfMemory) and: [self oop: oop isLessThan: freeStart])
ifFalse: [ self print: 'oop '; printHex: oop; print: ' is not a valid address'; cr. ^false ].
+ ((oop \\ self wordSize) = 0)
- ((oop \\ BytesPerWord) = 0)
ifFalse: [ self print: 'oop '; printHex: oop; print: ' is not a word-aligned address'; cr. ^false ].
sz := self sizeBitsOf: oop.
(self oop: oop + sz isLessThanOrEqualTo: freeStart)
ifFalse: [ self print: 'oop '; printHex: oop; print: ' size would make it extend beyond the end of memory'; cr. ^false ].
"header type checks"
type := self headerType: oop.
type = HeaderTypeFree
ifTrue: [ self print: 'oop '; printHex: oop; print: ' is a free chunk, not an object'; cr. ^false ].
type = HeaderTypeShort ifTrue: [
(self compactClassIndexOf: oop) = 0
ifTrue: [ self print: 'oop '; printHex: oop; print: ' cannot have zero compact class field in a short header'; cr. ^false ].
].
type = HeaderTypeClass ifTrue: [
+ ((oop >= self wordSize) and: [(self headerType: oop - self wordSize) = type])
- ((oop >= BytesPerWord) and: [(self headerType: oop - BytesPerWord) = type])
ifFalse: [ self print: 'oop '; printHex: oop; print: ' class header word has wrong type'; cr. ^false ].
].
type = HeaderTypeSizeAndClass ifTrue: [
+ ((oop >= (self wordSize*2)) and:
+ [(self headerType: oop - (self wordSize*2)) = type and:
+ [(self headerType: oop - self wordSize) = type]])
- ((oop >= (BytesPerWord*2)) and:
- [(self headerType: oop - (BytesPerWord*2)) = type and:
- [(self headerType: oop - BytesPerWord) = type]])
ifFalse: [ self print: 'oop '; printHex: oop; print: ' class header word has wrong type'; cr. ^false ].
].
"format check"
fmt := self formatOf: oop.
((fmt = 5) | (fmt = 7))
ifTrue: [ self print: 'oop '; printHex: oop; print: ' has an unknown format type'; cr. ^false ].
"mark and root bit checks"
unusedBit := 16r20000000.
+ self wordSize = 8
- BytesPerWord = 8
ifTrue:
[unusedBit := unusedBit << 16.
unusedBit := unusedBit << 16].
((self longAt: oop) bitAnd: unusedBit) = 0
ifFalse: [ self print: 'oop '; printHex: oop; print: ' unused header bit 30 is set; should be zero'; cr. ^false ].
"xxx
((self longAt: oop) bitAnd: MarkBit) = 0
ifFalse: [ self print: 'mark bit should not be set except during GC' ].
xxx"
((self isYoungRoot: oop) and: [oop >= youngStart])
ifTrue: [ self print: 'oop '; printHex: oop; print: ' root bit is set in a young object'; cr. ^false ].
^true
!
Item was changed:
----- Method: NewObjectMemory>>classFieldOffset (in category 'cog jit support') -----
classFieldOffset
<api>
<cmacro: '() (0 - BaseHeaderSize)'>
+ ^0 - self baseHeaderSize!
- ^0 - BaseHeaderSize!
Item was changed:
----- Method: NewObjectMemory>>clone: (in category 'allocation') -----
clone: obj
"Return a shallow copy of the given object. May cause GC.
Assume: Oop is a real object, not a small integer.
Override to assert it's not a married context and maybe fix cloned methods."
| extraHdrBytes bytes newChunk remappedOop fromIndex toIndex lastFrom newOop header hash |
<inline: false>
<var: #lastFrom type: #usqInt>
<var: #fromIndex type: #usqInt>
self assert: ((self isContext: obj) not
or: [(coInterpreter isMarriedOrWidowedContext: obj) not]).
self assert: (self isNonIntegerObject: obj).
extraHdrBytes := self extraHeaderBytes: obj.
bytes := self sizeBitsOf: obj.
bytes := bytes + extraHdrBytes.
"allocate space for the copy, remapping obj in case of a GC"
self pushRemappableOop: obj.
"check it is safe to allocate this much memory. Return 0 if not"
(self sufficientSpaceToAllocate: 2500 + bytes) ifFalse:[^0].
newChunk := self allocateChunk: bytes.
remappedOop := self popRemappableOop.
"copy old to new including all header words"
+ toIndex := newChunk - self wordSize. "loop below uses pre-increment"
+ fromIndex := (remappedOop - extraHdrBytes) - self wordSize.
- toIndex := newChunk - BytesPerWord. "loop below uses pre-increment"
- fromIndex := (remappedOop - extraHdrBytes) - BytesPerWord.
lastFrom := fromIndex + bytes.
[fromIndex < lastFrom] whileTrue:
+ [self longAt: (toIndex := toIndex + self wordSize)
+ put: (self longAt: (fromIndex := fromIndex + self wordSize))].
- [self longAt: (toIndex := toIndex + BytesPerWord)
- put: (self longAt: (fromIndex := fromIndex + BytesPerWord))].
newOop := newChunk + extraHdrBytes. "convert from chunk to oop"
"fix base header: compute new hash and clear Mark and Root bits"
hash := self newObjectHash.
header := (self longAt: newOop) bitAnd: 16r1FFFF.
"use old ccIndex, format, size, and header-type fields"
header := header bitOr: ((hash << HashBitsOffset) bitAnd: HashBits).
self longAt: newOop put: header.
(self isCompiledMethodHeader: header) ifTrue:
[coInterpreter maybeFixClonedCompiledMethod: newOop].
^newOop
!
Item was changed:
----- Method: NewObjectMemory>>eeAllocate:headerSize:h1:h2:h3: (in category 'allocation') -----
eeAllocate: byteSize headerSize: hdrSize h1: baseHeader h2: classOop h3: extendedSize
"Allocate a new object of the given size and number of header words. (Note: byteSize already includes
space for the base header word.) Initialize the header fields of the new object.
Does *not* initialize the objects' fields. Will *not* cause a GC. This version is for the execution engine's use only."
| newObj |
<inline: true>
+ newObj := self allocateInterpreterChunk: byteSize + (hdrSize - 1 * self wordSize).
- <asmLabel: false>
- newObj := self allocateInterpreterChunk: byteSize + (hdrSize - 1 * BytesPerWord).
newObj = 0 ifTrue: [^newObj].
hdrSize = 3 ifTrue:
[self longAt: newObj put: (extendedSize bitOr: HeaderTypeSizeAndClass).
+ self longAt: newObj + self wordSize put: (classOop bitOr: HeaderTypeSizeAndClass).
+ self longAt: newObj + (self wordSize*2) put: (baseHeader bitOr: HeaderTypeSizeAndClass).
+ newObj := newObj + (self wordSize*2)].
- self longAt: newObj + BytesPerWord put: (classOop bitOr: HeaderTypeSizeAndClass).
- self longAt: newObj + (BytesPerWord*2) put: (baseHeader bitOr: HeaderTypeSizeAndClass).
- newObj := newObj + (BytesPerWord*2)].
hdrSize = 2 ifTrue:
[self longAt: newObj put: (classOop bitOr: HeaderTypeClass).
+ self longAt: newObj + self wordSize put: (baseHeader bitOr: HeaderTypeClass).
+ newObj := newObj + self wordSize].
- self longAt: newObj + BytesPerWord put: (baseHeader bitOr: HeaderTypeClass).
- newObj := newObj + BytesPerWord].
hdrSize = 1 ifTrue:
[self longAt: newObj put: (baseHeader bitOr: HeaderTypeShort)].
DoExpensiveAssertionChecks ifTrue:
[self okayOop: newObj.
self oopHasOkayClass: newObj.
(self safeObjectAfter: newObj) = freeStart ifFalse:
[self error: 'allocate bug: did not set header of new oop correctly']].
^newObj!
Item was changed:
----- Method: NewObjectMemory>>eeAllocate:headerSize:h1:h2:h3:doFill:format: (in category 'allocation') -----
eeAllocate: byteSize headerSize: hdrSize h1: baseHeader h2: classOop h3: extendedSize doFill: doFill format: format
"Allocate a new object of the given size and number of header words. (Note: byteSize already includes
space for the base header word.) Initialize the header fields of the new object and fill the remainder of
the object with the given value. Will not cause a GC. This version is for the execution engine"
| newObj |
<inline: true>
- <asmLabel: false>
<var: #i type: 'usqInt'>
<var: #end type: 'usqInt'>
+ newObj := self allocateInterpreterChunk: byteSize + (hdrSize - 1 * self wordSize).
- newObj := self allocateInterpreterChunk: byteSize + (hdrSize - 1 * BytesPerWord).
newObj = 0 ifTrue: [^newObj].
hdrSize = 3 ifTrue:
[self longAt: newObj put: (extendedSize bitOr: HeaderTypeSizeAndClass).
+ self longAt: newObj + self wordSize put: (classOop bitOr: HeaderTypeSizeAndClass).
+ self longAt: newObj + (self wordSize*2) put: (baseHeader bitOr: HeaderTypeSizeAndClass).
+ newObj := newObj + (self wordSize*2)].
- self longAt: newObj + BytesPerWord put: (classOop bitOr: HeaderTypeSizeAndClass).
- self longAt: newObj + (BytesPerWord*2) put: (baseHeader bitOr: HeaderTypeSizeAndClass).
- newObj := newObj + (BytesPerWord*2)].
hdrSize = 2 ifTrue:
[self longAt: newObj put: (classOop bitOr: HeaderTypeClass).
+ self longAt: newObj + self wordSize put: (baseHeader bitOr: HeaderTypeClass).
+ newObj := newObj + self wordSize].
- self longAt: newObj + BytesPerWord put: (baseHeader bitOr: HeaderTypeClass).
- newObj := newObj + BytesPerWord].
hdrSize = 1 ifTrue:
[self longAt: newObj put: (baseHeader bitOr: HeaderTypeShort)].
"clear new object"
doFill ifTrue:
[| fillWord end i |
fillWord := format <= self lastPointerFormat
ifTrue: [nilObj] "if pointers, fill with nil oop"
ifFalse: [0].
end := newObj + byteSize.
+ i := newObj + self wordSize.
- i := newObj + BytesPerWord.
[i < end] whileTrue:
[self longAt: i put: fillWord.
+ i := i + self wordSize]].
- i := i + BytesPerWord]].
DoExpensiveAssertionChecks ifTrue:
[self okayOop: newObj.
self oopHasOkayClass: newObj.
(self safeObjectAfter: newObj) = freeStart ifFalse:
[self error: 'allocate bug: did not set header of new oop correctly']].
^newObj!
Item was changed:
----- Method: NewObjectMemory>>eeInstantiateAndInitializeClass:indexableSize: (in category 'interpreter access') -----
eeInstantiateAndInitializeClass: classPointer indexableSize: size
"NOTE: This method supports the backward-compatible split instSize field of the
class format word. The sizeHiBits will go away and other shifts change by 2
when the split fields get merged in an (incompatible) image change.
Will *not* cause a GC. The instantiated object is initialized."
| hash header1 header2 cClass byteSize format binc header3 hdrSize sizeHiBits bm1 classFormat |
<inline: false>
"cannot have a negative indexable field count"
self assert: size >= 0.
hash := self newObjectHash.
classFormat := self formatOfClass: classPointer.
"Low 2 bits are 0"
header1 := (classFormat bitAnd: 16r1FF00) bitOr: (hash bitAnd: HashMaskUnshifted) << HashBitsOffset.
header2 := classPointer.
header3 := 0.
sizeHiBits := (classFormat bitAnd: 16r60000) >> 9.
cClass := header1 bitAnd: CompactClassMask. "compact class field from format word"
byteSize := (classFormat bitAnd: SizeMask + Size4Bit) + sizeHiBits.
"size in bytes -- low 2 bits are 0"
"Note this byteSize comes from the format word of the class which is pre-shifted
to 4 bytes per field. Need another shift for 8 bytes per word..."
+ byteSize := byteSize << (self shiftForWord-2).
- byteSize := byteSize << (ShiftForWord-2).
format := self formatOfHeader: classFormat.
self flag: #sizeLowBits.
format < self firstByteFormat
ifTrue:
[format = self firstLongFormat
ifTrue: "long32 bitmaps"
+ [bm1 := self wordSize-1.
- [bm1 := BytesPerWord-1.
byteSize := byteSize + (size * 4) + bm1 bitAnd: LongSizeMask. "round up"
binc := bm1 - ((size * 4) + bm1 bitAnd: bm1). "odd bytes"
"extra low bit (4) for 64-bit VM goes in 4-bit (betw hdr bits and sizeBits)"
header1 := header1 bitOr: (binc bitAnd: 4)]
ifFalse: "Arrays and 64-bit bitmaps"
+ [byteSize := byteSize + (size * self wordSize)]]
- [byteSize := byteSize + (size * BytesPerWord)]]
ifFalse:
["Strings and Methods"
+ bm1 := self wordSize-1.
- bm1 := BytesPerWord-1.
byteSize := byteSize + size + bm1 bitAnd: LongSizeMask. "round up"
binc := bm1 - (size + bm1 bitAnd: bm1). "odd bytes"
"low bits of byte size go in format field"
header1 := header1 bitOr: (binc bitAnd: 3) << self instFormatFieldLSB.
"extra low bit (4) for 64-bit VM goes in 4-bit (betw hdr bits and sizeBits)"
header1 := header1 bitOr: (binc bitAnd: 4)].
byteSize > 255
ifTrue: "requires size header word"
[header3 := byteSize.
header1 := header1]
ifFalse: [header1 := header1 bitOr: byteSize].
hdrSize := header3 > 0
ifTrue: [3] "requires full header"
ifFalse: [cClass = 0 ifTrue: [2] ifFalse: [1]].
^self eeAllocate: byteSize headerSize: hdrSize h1: header1 h2: header2 h3: header3 doFill: true format: format!
Item was changed:
----- Method: NewObjectMemory>>eeInstantiateClass:indexableSize: (in category 'interpreter access') -----
eeInstantiateClass: classPointer indexableSize: size
"NOTE: This method supports the backward-compatible split instSize field of the
class format word. The sizeHiBits will go away and other shifts change by 2
when the split fields get merged in an (incompatible) image change.
Will *not* cause a GC.
Note that the instantiated object IS NOT FILLED and must be completed before
returning it to Smalltalk. Since this call is used in routines that do just that we are
safe. Break this rule and die."
<api>
| hash header1 header2 cClass byteSize format binc header3 hdrSize sizeHiBits bm1 classFormat |
<inline: false>
"cannot have a negative indexable field count"
self assert: size >= 0.
hash := self newObjectHash.
classFormat := self formatOfClass: classPointer.
"Low 2 bits are 0"
header1 := (classFormat bitAnd: 16r1FF00) bitOr: (hash bitAnd: HashMaskUnshifted) << HashBitsOffset.
header2 := classPointer.
header3 := 0.
sizeHiBits := (classFormat bitAnd: 16r60000) >> 9.
cClass := header1 bitAnd: CompactClassMask. "compact class field from format word"
byteSize := (classFormat bitAnd: SizeMask + Size4Bit) + sizeHiBits.
"size in bytes -- low 2 bits are 0"
"Note this byteSize comes from the format word of the class which is pre-shifted
to 4 bytes per field. Need another shift for 8 bytes per word..."
+ byteSize := byteSize << (self shiftForWord-2).
- byteSize := byteSize << (ShiftForWord-2).
format := self formatOfHeader: classFormat.
self flag: #sizeLowBits.
format < self firstByteFormat
ifTrue:
[format = self firstLongFormat
ifTrue: "long32 bitmaps"
+ [bm1 := self wordSize-1.
- [bm1 := BytesPerWord-1.
byteSize := byteSize + (size * 4) + bm1 bitAnd: LongSizeMask. "round up"
binc := bm1 - ((size * 4) + bm1 bitAnd: bm1). "odd bytes"
"extra low bit (4) for 64-bit VM goes in 4-bit (betw hdr bits and sizeBits)"
header1 := header1 bitOr: (binc bitAnd: 4)]
ifFalse: "Arrays and 64-bit bitmaps"
+ [byteSize := byteSize + (size * self wordSize)]]
- [byteSize := byteSize + (size * BytesPerWord)]]
ifFalse:
["Strings and Methods"
+ bm1 := self wordSize-1.
- bm1 := BytesPerWord-1.
byteSize := byteSize + size + bm1 bitAnd: LongSizeMask. "round up"
binc := bm1 - (size + bm1 bitAnd: bm1). "odd bytes"
"low bits of byte size go in format field"
header1 := header1 bitOr: (binc bitAnd: 3) << self instFormatFieldLSB.
"extra low bit (4) for 64-bit VM goes in 4-bit (betw hdr bits and sizeBits)"
header1 := header1 bitOr: (binc bitAnd: 4)].
byteSize > 255
ifTrue: "requires size header word"
[header3 := byteSize.
header1 := header1]
ifFalse: [header1 := header1 bitOr: byteSize].
hdrSize := header3 > 0
ifTrue: [3] "requires full header"
ifFalse: [cClass = 0 ifTrue: [2] ifFalse: [1]].
^self eeAllocate: byteSize headerSize: hdrSize h1: header1 h2: header2 h3: header3!
Item was changed:
----- Method: NewObjectMemory>>eeInstantiateClassIndex:format:numSlots: (in category 'interpreter access') -----
eeInstantiateClassIndex: compactClassIndex format: objFormat numSlots: numSlots
"Instantiate an instance of a compact class. ee stands for execution engine and
implies that this allocation will *NOT* cause a GC. N.B. the instantiated object
IS NOT FILLED and must be completed before returning it to Smalltalk. Since this
call is used in routines that do just that we are safe. Break this rule and die in GC.
Result is guaranteed to be young."
<api>
| hash header1 header2 byteSize header3 hdrSize |
<inline: false>
"cannot have a negative indexable field count"
self assert: (numSlots >= 0 and: [compactClassIndex ~= 0]).
self assert: (objFormat < self firstByteFormat
ifTrue: [objFormat]
ifFalse: [objFormat bitAnd: self byteFormatMask])
= (self instSpecOfClass: (self compactClassAt: compactClassIndex)).
hash := self newObjectHash.
"Low 2 bits are 0"
header1 := (objFormat << self instFormatFieldLSB
bitOr: compactClassIndex << 12)
bitOr: (hash bitAnd: HashMaskUnshifted) << HashBitsOffset.
self assert: "sizeHiBits" ((self formatOfClass: (self compactClassAt: compactClassIndex)) bitAnd: 16r60000) >> 9 = 0.
self flag: #sizeLowBits.
"size in bytes -- low 2 bits are 0; may need another shift if 64-bits.
strangely, size includes size of header, but only of single header.
why include header size at all? gives us an extra word."
+ byteSize := numSlots << (self shiftForWord + (self shiftForWord-2)) + self baseHeaderSize.
+ (self wordSize = 8 "David, please check this!!!!"
- byteSize := numSlots << (ShiftForWord + (ShiftForWord-2)) + BaseHeaderSize.
- (BytesPerWord = 8 "David, please check this!!!!"
and: [objFormat >= self firstLongFormat "32-bit longs and byte objects"
and: [(numSlots bitAnd: 1) ~= 0]]) ifTrue:
["extra low bit (4) for 64-bit VM goes in 4-bit (betw hdr bits and sizeBits)"
header1 := header1 bitOr: 4].
byteSize > 255 "requires size header word/full header"
ifTrue: [header3 := byteSize. hdrSize := 3. header2 := self compactClassAt: compactClassIndex]
ifFalse: [header1 := header1 bitOr: byteSize. hdrSize := 1].
^self eeAllocate: byteSize headerSize: hdrSize h1: header1 h2: header2 h3: header3!
Item was changed:
----- Method: NewObjectMemory>>eeInstantiateMethodContextSlots: (in category 'interpreter access') -----
eeInstantiateMethodContextSlots: numSlots
"This version of instantiateClass assumes that the total object
size is under 256 bytes, the limit for objects with only one or
two header words. Note that the size is specified in bytes
and should include four bytes for the base header word.
Will *not* cause a GC. Result is guaranteed to be young."
| sizeInBytes hash header1 |
self assert: (numSlots = SmallContextSlots or: [numSlots = LargeContextSlots]).
+ sizeInBytes := numSlots * self bytesPerOop + self baseHeaderSize.
- sizeInBytes := numSlots * BytesPerOop + BaseHeaderSize.
self assert: sizeInBytes <= SizeMask.
hash := self newObjectHash.
header1 := (hash bitAnd: HashMaskUnshifted) << HashBitsOffset bitOr: self formatOfMethodContextMinusSize.
self assert: (header1 bitAnd: CompactClassMask) > 0. "contexts must be compact"
self assert: (header1 bitAnd: SizeMask) = 0.
"OR size into header1. Must not do this if size > SizeMask"
header1 := header1 + sizeInBytes.
^self eeAllocate: sizeInBytes headerSize: 1 h1: header1 h2: nil h3: nil!
Item was changed:
----- Method: NewObjectMemory>>eeInstantiateSmallClass:numSlots: (in category 'interpreter access') -----
eeInstantiateSmallClass: classPointer numSlots: numSlots
"This version of instantiateClass assumes that the total object size is under
256 bytes, the limit for objects with only one or two header words.
NOTE this code will only work for sizes that are an integral number of words
(hence not a 32-bit LargeInteger in a 64-bit system).
Note that the created small object IS NOT FILLED and must be completed before returning it to Squeak.
Since this call is used in routines that do just that we are safe. Break this rule and die in GC.
Will *not* cause a GC. Result is guaranteed to be young."
| sizeInBytes hash header1 header2 hdrSize |
+ sizeInBytes := numSlots << self shiftForWord + self baseHeaderSize.
- sizeInBytes := numSlots << ShiftForWord + BaseHeaderSize.
self assert: sizeInBytes <= 252.
hash := self newObjectHash.
header1 := (hash bitAnd: HashMaskUnshifted) << HashBitsOffset bitOr: (self formatOfClass: classPointer).
header2 := classPointer.
hdrSize := (header1 bitAnd: CompactClassMask) > 0 "is this a compact class"
ifTrue: [1]
ifFalse: [2].
header1 := header1 + (sizeInBytes - (header1 bitAnd: SizeMask+Size4Bit)).
^self eeAllocate: sizeInBytes headerSize: hdrSize h1: header1 h2: header2 h3: 0!
Item was changed:
----- Method: NewObjectMemory>>eeInstantiateSmallClassIndex:format:numSlots: (in category 'interpreter access') -----
eeInstantiateSmallClassIndex: compactClassIndex format: objFormat numSlots: numSlots
"This version of instantiateClass assumes that the total object size is under
256 bytes, the limit for objects with only one or two header words.
NOTE this code will only work for sizes that are an integral number of words
(hence not a 32-bit LargeInteger in a 64-bit system).
Note that the created small object IS NOT FILLED and must be completed before returning it to Squeak.
Since this call is used in routines that do just that we are safe. Break this rule and die in GC.
Will *not* cause a GC. Result is guaranteed to be young."
| sizeInBytes hash header1 |
"cannot have a negative indexable field count"
self assert: (numSlots >= 0 and: [compactClassIndex ~= 0]).
self assert: (objFormat < self firstByteFormat
ifTrue: [objFormat]
ifFalse: [objFormat bitAnd: self byteFormatMask])
= (self instSpecOfClass: (self compactClassAt: compactClassIndex)).
+ sizeInBytes := numSlots << self shiftForWord + self baseHeaderSize.
- sizeInBytes := numSlots << ShiftForWord + BaseHeaderSize.
self assert: sizeInBytes <= 252.
hash := self newObjectHash.
header1 := (objFormat << self instFormatFieldLSB
bitOr: compactClassIndex << 12)
bitOr: (hash bitAnd: HashMaskUnshifted) << HashBitsOffset.
header1 := header1 + (sizeInBytes - (header1 bitAnd: SizeMask+Size4Bit)).
^self eeAllocate: sizeInBytes headerSize: 1 h1: header1 h2: 0 h3: 0!
Item was changed:
----- Method: NewObjectMemory>>findString: (in category 'debug support') -----
findString: aCString
"Print the oops of all string-like things that have the same characters as aCString"
<api>
<var: #aCString type: #'char *'>
| cssz obj sz |
cssz := self strlen: aCString.
obj := self firstObject.
[self oop: obj isLessThan: freeStart] whileTrue:
[(self isFreeObject: obj)
ifTrue:
[sz := self sizeOfFree: obj]
ifFalse:
[((self isBytesNonImm: obj)
and: [(self lengthOf: obj) = cssz
+ and: [(self str: aCString n: (self pointerForOop: obj + self baseHeaderSize) cmp: cssz) = 0]]) ifTrue:
- and: [(self str: aCString n: (self pointerForOop: obj + BaseHeaderSize) cmp: cssz) = 0]]) ifTrue:
[coInterpreter printHex: obj; space; printOopShort: obj; cr].
sz := self sizeBitsOf: obj].
obj := self oopFromChunk: obj + sz]!
Item was changed:
----- Method: NewObjectMemory>>findStringBeginningWith: (in category 'debug support') -----
findStringBeginningWith: aCString
"Print the oops of all string-like things that start with the same characters as aCString"
<api>
<var: #aCString type: #'char *'>
| cssz obj sz |
cssz := self strlen: aCString.
obj := self firstObject.
[self oop: obj isLessThan: freeStart] whileTrue:
[(self isFreeObject: obj)
ifTrue:
[sz := self sizeOfFree: obj]
ifFalse:
[((self isBytesNonImm: obj)
and: [(self lengthOf: obj) >= cssz
+ and: [(self str: aCString n: (self pointerForOop: obj + self baseHeaderSize) cmp: cssz) = 0]]) ifTrue:
- and: [(self str: aCString n: (self pointerForOop: obj + BaseHeaderSize) cmp: cssz) = 0]]) ifTrue:
[coInterpreter printHex: obj; space; printNum: (self lengthOf: obj); space; printOopShort: obj; cr].
sz := self sizeBitsOf: obj].
obj := self oopFromChunk: obj + sz]!
Item was changed:
----- Method: NewObjectMemory>>formatOfMethodContext (in category 'frame access') -----
formatOfMethodContext
"Answer the class format word for MethodContext which is used to instantiate
contexts without needing to fetch it from the class MethodContext itself."
^(ClassMethodContextCompactIndex << 12)
+ (self indexablePointersFormat << self instFormatFieldLSB) "Pointers+Variable"
+ + (CtxtTempFrameStart + (self baseHeaderSize / self wordSize) << 2)!
- + (CtxtTempFrameStart + (BaseHeaderSize / BytesPerWord) << 2)!
Item was changed:
----- Method: NewObjectMemory>>fullCompaction (in category 'garbage collection') -----
fullCompaction
"Move all accessible objects down to leave one big free chunk at the end of memory.
Assume:
Incremental GC has just been done to maximimize forwarding table space.
sweepPhaseForFullGC has already set compStart.
Need not and can not move objects below the first free chunk."
| sz |
- <asmLabel: false>
self assert: compStart = (self lowestFreeAfter: self startOfMemory).
compStart = freeStart ifTrue:
["memory is already compact; only free chunk is at the end "
^self initializeMemoryFirstFree: freeStart].
(sz := self fwdTableSize: 8) < totalObjectCount ifTrue:
["Try to grow OM to make a single pass full GC"
self growObjectMemory: totalObjectCount - sz + 10000 * 8].
"work up through memory until all free space is at the end"
[compStart < freeStart] whileTrue:
["free chunk returned by incCompBody becomes start of next compaction"
compStart := self incCompBody]!
Item was changed:
----- Method: NewObjectMemory>>fwdTableInit: (in category 'gc -- compaction') -----
fwdTableInit: blkSize
"Set the limits for a table of two- or three-word forwarding blocks above the last used oop. The pointer fwdTableNext moves up to fwdTableLast. Used for compaction of memory and become-ing objects. Returns the number of forwarding blocks available."
<inline: false>
"set endOfMemory to just after a minimum-sized free block"
+ self setSizeOfFree: freeStart to: self baseHeaderSize.
+ self setEndOfMemory: freeStart + self baseHeaderSize.
- self setSizeOfFree: freeStart to: BaseHeaderSize.
- self setEndOfMemory: freeStart + BaseHeaderSize.
"make a fake free chunk at endOfMemory for use as a sentinal in memory scans"
+ self setSizeOfFree: endOfMemory to: self baseHeaderSize.
- self setSizeOfFree: endOfMemory to: BaseHeaderSize.
"use all memory free between freeStart and memoryLimit for forwarding table"
"Note: Forward blocks must be quadword aligned."
+ fwdTableNext := (endOfMemory + self baseHeaderSize + 7) bitAnd: WordMask-7.
- fwdTableNext := (endOfMemory + BaseHeaderSize + 7) bitAnd: WordMask-7.
self flag: #Dan. "Above line does not do what it says (quadword is 16 or 32 bytes)"
fwdTableLast := memoryLimit - blkSize. "last forwarding table entry"
"return the number of forwarding blocks available"
^(fwdTableLast - fwdTableNext) // blkSize "round down"!
Item was changed:
----- Method: NewObjectMemory>>fwdTableSize: (in category 'gc -- compaction') -----
fwdTableSize: blkSize
"Estimate the number of forwarding blocks available for compaction"
| eom fwdFirst fwdLast |
<inline: false>
+ eom := freeStart + self baseHeaderSize.
- eom := freeStart + BaseHeaderSize.
"use all memory free between freeStart and memoryLimit for forwarding table"
"Note: Forward blocks must be quadword aligned."
+ fwdFirst := (eom + self baseHeaderSize + 7) bitAnd: WordMask-7.
- fwdFirst := (eom + BaseHeaderSize + 7) bitAnd: WordMask-7.
self flag: #Dan. "Above line does not do what it says (quadword is 16 or 32 bytes)"
fwdLast := memoryLimit - blkSize. "last forwarding table entry"
"return the number of forwarding blocks available"
^ (fwdLast - fwdFirst) // blkSize "round down"!
Item was changed:
----- Method: NewObjectMemory>>imageSegmentVersion (in category 'image segment in/out') -----
imageSegmentVersion
| wholeWord |
"a more complex version that tells both the word reversal and the endianness of the machine it came from. Low half of word is 6502. Top byte is top byte of #doesNotUnderstand: on this machine. ($d on the Mac or $s on the PC)"
+ wholeWord := self longAt: (self splObj: SelectorDoesNotUnderstand) + self baseHeaderSize.
- wholeWord := self longAt: (self splObj: SelectorDoesNotUnderstand) + BaseHeaderSize.
"first data word, 'does' "
^coInterpreter imageFormatVersion bitOr: (wholeWord bitAnd: 16rFF000000)!
Item was changed:
----- Method: NewObjectMemory>>incCompBody (in category 'gc -- compaction') -----
incCompBody
"Move objects to consolidate free space into one big chunk. Return the newly created free chunk."
| bytesToBeFreed |
<inline: false>
"reserve memory for forwarding table"
+ self fwdTableInit: self wordSize*2. "Two-word blocks"
- self fwdTableInit: BytesPerWord*2. "Two-word blocks"
"assign new oop locations, reverse their headers, and initialize forwarding blocks"
bytesToBeFreed := self incCompMakeFwd.
"update pointers to point at new oops"
self mapPointersInObjectsFrom: youngStart to: freeStart.
"move the objects and restore their original headers; return the new free chunk"
^self incCompMove: bytesToBeFreed!
Item was changed:
----- Method: NewObjectMemory>>incCompMakeFwd (in category 'gc -- compaction') -----
incCompMakeFwd
"Create and initialize forwarding blocks for all non-free objects
following compStart. If the supply of forwarding blocks is exhausted,
set compEnd to the first chunk above the area to be compacted;
otherwise, set it to endOfMemory. Return the number of bytes to be freed."
| bytesToBeFreed oop fwdBlock newOop |
<inline: false>
bytesToBeFreed := 0.
oop := self oopFromChunk: compStart.
self assert: (self oop: oop isGreaterThan: self startOfMemory andLessThan: freeStart).
[self oop: oop isLessThan: freeStart] whileTrue:
[statMkFwdCount := statMkFwdCount + 1.
self assert: (self oop: oop isGreaterThan: self startOfMemory andLessThan: freeStart).
(self isFreeObject: oop)
ifTrue: [bytesToBeFreed := bytesToBeFreed + (self sizeOfFree: oop)]
ifFalse: "create a forwarding block for oop"
+ [fwdBlock := self fwdBlockGet: self wordSize*2.
- [fwdBlock := self fwdBlockGet: BytesPerWord*2.
"Two-word block"
fwdBlock = nil ifTrue: "stop; we have used all available forwarding blocks"
[compEnd := self chunkFromOop: oop.
^bytesToBeFreed].
newOop := oop - bytesToBeFreed.
self assert: (self oop: newOop isGreaterThan: self startOfMemory andLessThan: freeStart).
self initForwardBlock: fwdBlock mapping: oop to: newOop withBackPtr: false].
oop := self objectAfterWhileForwarding: oop].
compEnd := freeStart.
^bytesToBeFreed!
Item was changed:
----- Method: NewObjectMemory>>incCompMove: (in category 'gc -- compaction') -----
incCompMove: bytesFreed
"Move all non-free objects between compStart and compEnd to their new
locations, restoring their headers in the process. Create a new free
block at the end of memory. Return the newly created free chunk. "
"Note: The free block used by the allocator always must be the last free
block in memory. It may take several compaction passes to make all
free space bubble up to the end of memory."
| oop next fwdBlock newOop header bytesToMove firstWord lastWord newFreeChunk sz target |
<inline: false>
<var: #firstWord type: 'usqInt'>
<var: #lastWord type: 'usqInt'>
<var: #w type: 'usqInt'>
newOop := nil.
oop := self oopFromChunk: compStart.
[self oop: oop isLessThan: compEnd] whileTrue:
[statCompMoveCount := statCompMoveCount + 1.
next := self objectAfterWhileForwarding: oop.
(self isFreeObject: oop) ifFalse:
["a moving object; unwind its forwarding block"
fwdBlock := self forwardingPointerOf: oop.
self assert: (self fwdBlockValid: fwdBlock).
newOop := self longAt: fwdBlock.
+ header := self longAt: fwdBlock + self wordSize.
- header := self longAt: fwdBlock + BytesPerWord.
self longAt: oop put: header. "restore the original header"
bytesToMove := oop - newOop. "move the oop (including any extra header words) "
sz := self sizeBitsOf: oop.
firstWord := oop - (self extraHeaderBytes: oop).
+ lastWord := oop + sz - self baseHeaderSize.
- lastWord := oop + sz - BaseHeaderSize.
target := firstWord - bytesToMove.
+ firstWord to: lastWord by: self wordSize do:
- firstWord to: lastWord by: BytesPerWord do:
[:w |
self longAt: target put: (self longAt: w).
+ target := target + self wordSize]].
- target := target + BytesPerWord]].
oop := next].
newOop = nil
ifTrue: ["no objects moved"
oop := self oopFromChunk: compStart.
((self isFreeObject: oop) and: [(self objectAfter: oop) = (self oopFromChunk: compEnd)])
ifTrue: [newFreeChunk := oop]
ifFalse: [newFreeChunk := freeStart]]
ifFalse: ["initialize the newly freed memory chunk"
"newOop is the last object moved; free chunk starts right after it"
newFreeChunk := newOop + (self sizeBitsOf: newOop).
self setSizeOfFree: newFreeChunk to: bytesFreed].
next := self safeObjectAfter: newFreeChunk.
self assert: (next = freeStart or: [next = (self oopFromChunk: compEnd)]).
next = freeStart
ifTrue: [self initializeMemoryFirstFree: newFreeChunk]
ifFalse: ["newFreeChunk is not at end of memory; re-install freeStart.
This will be the case when a compaction needs more than one pass."
self initializeMemoryFirstFree: freeStart].
^newFreeChunk!
Item was changed:
----- Method: NewObjectMemory>>initForwardBlock:mapping:to:withBackPtr: (in category 'gc -- compaction') -----
initForwardBlock: fwdBlock mapping: objOop to: newOop withBackPtr: backFlag
"Initialize the given forwarding block to map oop to newOop,
and replace oop's header with a pointer to the fowarding block."
"Details: The mark bit is used to indicate that an oop is
forwarded. When an oop is forwarded, its header (minus the
mark bit) contains the address of its forwarding block. (The
forwarding block address is actually shifted right by one bit
so that its top-most bit does not conflict with the header's
mark bit; since fowarding blocks are stored on word
boundaries, the low two bits of the address are always zero.)
The first word of the forwarding block is the new oop; the
second word is the oop's orginal header. In the case of a
forward become, a four-word block is used, with the third
field being a backpointer to the old oop (for header fixup),
and the fourth word is unused. The type bits of the
forwarding header are the same as those of the original
header. "
| originalHeader originalHeaderType |
<inline: true>
- <asmLabel: false>
self assert: fwdBlock ~= nil. "ran out of forwarding blocks in become"
self deny: (self hasForwardingBlock: objOop). "'object already has a forwarding table entry"
originalHeader := self longAt: objOop.
originalHeaderType := originalHeader bitAnd: TypeMask.
self longAt: fwdBlock put: newOop.
+ self longAt: fwdBlock + self wordSize put: originalHeader.
+ backFlag ifTrue: [self longAt: fwdBlock + (self wordSize*2) put: objOop].
- self longAt: fwdBlock + BytesPerWord put: originalHeader.
- backFlag ifTrue: [self longAt: fwdBlock + (BytesPerWord*2) put: objOop].
self longAt: objOop put: (fwdBlock >> 1 bitOr: (MarkBit bitOr: originalHeaderType))!
Item was changed:
----- Method: NewObjectMemory>>initializeMemoryFirstFree: (in category 'initialization') -----
initializeMemoryFirstFree: firstFree
"Initialize endOfMemory to the top of oop storage space, reserving some space
for forwarding blocks, and set freeStart from which space is allocated."
"Note: The amount of space reserved for forwarding blocks should be chosen to
ensure that incremental compactions can usually be done in a single pass.
However, there should be enough forwarding blocks so a full compaction can be done
in a reasonable number of passes, say ten. (A full compaction requires N object-moving
passes, where N = number of non-garbage objects / number of forwarding blocks).
di 11/18/2000 Re totalObjectCount: Provide a margin of one byte per object to be
used for forwarding pointers at GC time. Since fwd blocks are 8 bytes, this means
an absolute worst case of 8 passes to compact memory. In most cases it will be
adequate to do compaction in a single pass. "
| fwdBlockBytes totalReserve |
"reserve space for forwarding blocks and the interpreter. We can sacrifice
forwarding block space at the cost of slower compactions but we cannot
safely sacrifice interpreter allocation headroom."
+ fwdBlockBytes := totalObjectCount bitAnd: WordMask - self wordSize + 1.
- fwdBlockBytes := totalObjectCount bitAnd: WordMask - BytesPerWord + 1.
totalReserve := fwdBlockBytes + self interpreterAllocationReserveBytes.
+ (self oop: memoryLimit - totalReserve isLessThan: firstFree + self baseHeaderSize) ifTrue:
- (self oop: memoryLimit - totalReserve isLessThan: firstFree + BaseHeaderSize) ifTrue:
["reserve enough space for a minimal free block of BaseHeaderSize bytes.
We are apparently in an emergency situation here because we have no space
for reserve and forwarding blocks. But a full GC will occur immediately in
sufficientSpaceAfterGC: which will grow memory and restore the reserve."
+ fwdBlockBytes := memoryLimit - (firstFree + self baseHeaderSize)].
- fwdBlockBytes := memoryLimit - (firstFree + BaseHeaderSize)].
"set endOfMemory reserveStart and freeStart"
self setEndOfMemory: memoryLimit - fwdBlockBytes.
reserveStart := endOfMemory - self interpreterAllocationReserveBytes.
freeStart := firstFree. "bytes available for oops"
scavengeThreshold := freeStart + edenBytes min: reserveStart.
self maybeFillWithAllocationCheckFillerFrom: freeStart to: scavengeThreshold.
self assert: (self oop: freeStart isLessThan: reserveStart).
"We would like to assert this but can't because in GC situations it may be false. It is
established by sufficientSpaceToAllocate: and sufficientSpaceAfterGC:"
false ifTrue: [self assert: (self oop: reserveStart isLessThan: endOfMemory)].
self assert: (self oop: endOfMemory isLessThan: memoryLimit)!
Item was changed:
----- Method: NewObjectMemory>>lastPointerOf: (in category 'object enumeration') -----
lastPointerOf: objOop
"Return the byte offset of the last pointer field of the given object.
Can be used even when the type bits are not correct.
Works with CompiledMethods, as well as ordinary objects."
<api>
<inline: true>
- <asmLabel: false>
| fmt header contextSize |
header := self baseHeader: objOop.
fmt := self formatOfHeader: header.
fmt <= self lastPointerFormat ifTrue:
[(fmt = self indexablePointersFormat
and: [self isContextHeader: header]) ifTrue:
["contexts end at the stack pointer"
contextSize := coInterpreter fetchStackPointerOf: objOop.
+ ^CtxtTempFrameStart + contextSize * self bytesPerOop].
+ ^(self sizeBitsOfSafe: objOop) - self baseHeaderSize "all pointers"].
- ^CtxtTempFrameStart + contextSize * BytesPerOop].
- ^(self sizeBitsOfSafe: objOop) - BaseHeaderSize "all pointers"].
fmt < self firstCompiledMethodFormat ifTrue: [^0]. "no pointers"
"CompiledMethod: contains both pointers and bytes"
header := self methodHeaderOf: objOop.
^self lastPointerOfMethodHeader: header!
Item was changed:
----- Method: NewObjectMemory>>lastPointerOf:recordWeakRoot: (in category 'object enumeration') -----
lastPointerOf: objOop recordWeakRoot: recordWeakRoot "<Boolean>"
"Return the byte offset of the last pointer field of the given object.
Works with CompiledMethods, as well as ordinary objects.
Can be used even when the type bits are not correct.
This is a version of lastPointerOf: for markAndTrace:.
Already overridden to trace stack pages for the StackInterpreter.
Override to ask coInterpreter to determine literalCount of methods."
| fmt sz header contextSize numOops |
<inline: true>
- <asmLabel: false>
header := self baseHeader: objOop.
fmt := self formatOfHeader: header.
fmt <= self lastPointerFormat ifTrue:
[fmt >= self indexablePointersFormat ifTrue:
[fmt = self lastPointerFormat ifTrue:
[(recordWeakRoot and: [weakRootCount >= 0]) ifTrue:
["And remember as weak root"
(weakRootCount := weakRootCount + 1) <= WeakRootTableSize ifFalse:
[self error: 'weakRoots table overflow'].
weakRoots at: weakRootCount put: objOop].
"Do not trace the object's indexed fields if it's a weak class"
numOops := self nonWeakFieldsOf: objOop. "so nonWeakFieldsOf: may be inlined"
+ ^numOops * self wordSize].
- ^numOops * BytesPerWord].
"So fmt is 3"
(self isContextHeader: header) ifTrue:
[coInterpreter setTraceFlagOnContextsFramesPageIfNeeded: objOop.
"contexts end at the stack pointer avoiding having to init fields beyond it"
contextSize := coInterpreter fetchStackPointerOf: objOop.
self assert: ReceiverIndex + contextSize < (self lengthOf: objOop baseHeader: header format: fmt).
+ ^CtxtTempFrameStart + contextSize * self bytesPerOop]].
- ^CtxtTempFrameStart + contextSize * BytesPerOop]].
sz := self sizeBitsOfSafe: objOop.
+ ^sz - self baseHeaderSize "all pointers" ].
- ^sz - BaseHeaderSize "all pointers" ].
fmt < self firstCompiledMethodFormat ifTrue: [^0]. "no pointers"
"CompiledMethod: contains both pointers and bytes"
header := self methodHeaderOf: objOop.
^self lastPointerOfMethodHeader: header!
Item was changed:
----- Method: NewObjectMemory>>lastPointerOfMethodHeader: (in category 'object enumeration') -----
lastPointerOfMethodHeader: methodHeader
"Answer the byte offset of the last pointer field of a
CompiledMethod with the given header. Use a temp to
allow inlining given MULTIPLEBYTECODESETS complications."
<inline: true>
- <asmLabel: false>
| numLiterals |
numLiterals := self literalCountOfMethodHeader: methodHeader.
+ ^numLiterals + LiteralStart - 1 * self bytesPerOop + self baseHeaderSize!
- ^numLiterals + LiteralStart - 1 * BytesPerOop + BaseHeaderSize!
Item was changed:
----- Method: NewObjectMemory>>lastPointerWhileForwarding: (in category 'gc -- compaction') -----
lastPointerWhileForwarding: objOop
"The given object may have its header word in a forwarding block. Find
the offset of the last pointer in the object in spite of this obstacle."
| header fmt size contextSize |
<inline: true>
header := self headerWhileForwardingOf: objOop.
fmt := self formatOfHeader: header.
fmt <= self lastPointerFormat ifTrue:
[(fmt = self indexablePointersFormat
and: [self isContextHeader: header]) ifTrue:
["contexts end at the stack pointer"
contextSize := coInterpreter nacFetchStackPointerOf: objOop.
self assert: ReceiverIndex + contextSize < (self lengthOf: objOop baseHeader: header format: fmt).
+ ^CtxtTempFrameStart + contextSize * self bytesPerOop].
- ^CtxtTempFrameStart + contextSize * BytesPerOop].
"do sizeBitsOf: using the header we obtained"
size := (header bitAnd: TypeMask) = HeaderTypeSizeAndClass
ifTrue: [(self sizeHeader: objOop) bitAnd: AllButTypeMask]
ifFalse: [header bitAnd: SizeMask].
+ ^size - self baseHeaderSize].
- ^size - BaseHeaderSize].
fmt < self firstCompiledMethodFormat ifTrue: [^0]. "no pointers"
"CompiledMethod: contains both pointers and bytes"
self assert: (self isCompiledMethodHeader: header).
header := self noCheckMethodHeaderOf: objOop.
^self lastPointerOfMethodHeader: header!
Item was changed:
----- Method: NewObjectMemory>>loadImageSegmentFrom:outPointers: (in category 'image segment in/out') -----
loadImageSegmentFrom: segmentWordArray outPointers: outPointerArray
"This primitive is called from Squeak as...
<imageSegment> loadSegmentFrom: aWordArray outPointers: anArray."
"This primitive will load a binary image segment created by primitiveStoreImageSegment. It expects the outPointer array to be of the proper size, and the wordArray to be well formed. It will return as its value the original array of roots, and the erstwhile segmentWordArray will have been truncated to a size of one word, i.e. retaining the version stamp. If this primitive should fail, the segmentWordArray will, sadly, have been reduced to an unrecognizable and unusable jumble. But what more could you have done with it anyway?"
| endSeg segOop fieldPtr fieldOop doingClass lastPtr extraSize mapOop lastOut outPtr hdrTypeBits header data |
<inline: false>
<var: #endSeg type: #usqInt>
<var: #segOop type: #usqInt>
<var: #fieldPtr type: #usqInt>
<var: #lastOut type: #usqInt>
<var: #outPtr type: #usqInt>
<var: #lastPtr type: #usqInt>
DoAssertionChecks ifTrue: [self verifyCleanHeaders].
lastOut := outPointerArray + (self lastPointerOf: outPointerArray).
+ endSeg := segmentWordArray + (self sizeBitsOf: segmentWordArray) - self baseHeaderSize.
- endSeg := segmentWordArray + (self sizeBitsOf: segmentWordArray) - BaseHeaderSize.
"Version check. Byte order of the WordArray now"
+ data := self longAt: segmentWordArray + self baseHeaderSize.
- data := self longAt: segmentWordArray + BaseHeaderSize.
(coInterpreter readableFormat: (data bitAnd: 16rFFFF "low 2 bytes")) ifFalse:
"Not readable -- try again with reversed bytes..."
+ [self reverseBytesFrom: segmentWordArray + self baseHeaderSize to: endSeg + self wordSize.
+ data := self longAt: segmentWordArray + self baseHeaderSize.
- [self reverseBytesFrom: segmentWordArray + BaseHeaderSize to: endSeg + BytesPerWord.
- data := self longAt: segmentWordArray + BaseHeaderSize.
(coInterpreter readableFormat: (data bitAnd: 16rFFFF "low 2 bytes")) ifFalse:
"Still NG -- put things back and fail"
+ [self reverseBytesFrom: segmentWordArray + self baseHeaderSize to: endSeg + self wordSize.
- [self reverseBytesFrom: segmentWordArray + BaseHeaderSize to: endSeg + BytesPerWord.
DoAssertionChecks ifTrue: [self verifyCleanHeaders].
^PrimErrBadArgument]].
"Reverse the Byte type objects if the data is from opposite endian machine.
Revese the words in Floats if from an earlier version with different Float order.
Test top byte. $d on the Mac or $s on the PC. Rest of word is equal."
(data >> 16) = (self imageSegmentVersion >> 16)
ifTrue:
"Need to swap floats if the segment is being loaded into a little-endian VM from a version
that keeps Floats in big-endian word order as was the case prior to the 6505 image format."
[(self isPlatformFloatOrderVersion: (data bitAnd: 16rFFFF "low 2 bytes")) ifFalse:
[self vmEndianness ~= 1 "~= 1 => little-endian" ifTrue:
+ [segOop := self oopFromChunk: segmentWordArray + self baseHeaderSize + self wordSize.
+ self wordSwapFloatsFrom: segOop to: endSeg + self wordSize]]]
- [segOop := self oopFromChunk: segmentWordArray + BaseHeaderSize + BytesPerWord.
- self wordSwapFloatsFrom: segOop to: endSeg + BytesPerWord]]]
ifFalse: "Reverse the byte-type objects once"
+ [segOop := self oopFromChunk: segmentWordArray + self baseHeaderSize + self wordSize.
- [segOop := self oopFromChunk: segmentWordArray + BaseHeaderSize + BytesPerWord.
"Oop of first embedded object"
self byteSwapByteObjectsFrom: segOop
+ to: endSeg + self wordSize
- to: endSeg + BytesPerWord
flipFloatsIf: (self isPlatformFloatOrderVersion: (data bitAnd: 16rFFFF "low 2 bytes"))].
"Proceed through the segment, remapping pointers..."
+ segOop := self oopFromChunk: segmentWordArray + self baseHeaderSize + self wordSize.
- segOop := self oopFromChunk: segmentWordArray + BaseHeaderSize + BytesPerWord.
[segOop <= endSeg] whileTrue:
[(self headerType: segOop) <= 1
ifTrue: ["This object has a class field (type = 0 or 1) -- start with that."
+ fieldPtr := segOop - self wordSize. doingClass := true]
- fieldPtr := segOop - BytesPerWord. doingClass := true]
ifFalse: ["No class field -- start with first data field"
+ fieldPtr := segOop + self baseHeaderSize. doingClass := false].
- fieldPtr := segOop + BaseHeaderSize. doingClass := false].
lastPtr := segOop + (self lastPointerOf: segOop). "last field"
lastPtr > endSeg ifTrue:
[DoAssertionChecks ifTrue: [self verifyCleanHeaders].
^PrimErrBadIndex "out of bounds"].
"Go through all oops, remapping them..."
[fieldPtr > lastPtr] whileFalse:
["Examine each pointer field"
fieldOop := self longAt: fieldPtr.
doingClass ifTrue:
[hdrTypeBits := self headerType: fieldPtr.
fieldOop := fieldOop - hdrTypeBits].
(self isIntegerObject: fieldOop)
ifTrue:
["Integer -- nothing to do"
+ fieldPtr := fieldPtr + self wordSize]
- fieldPtr := fieldPtr + BytesPerWord]
ifFalse:
[(fieldOop bitAnd: 3) = 0 ifFalse:
[^PrimErrBadIndex "bad oop"].
(fieldOop bitAnd: 16r80000000) = 0
ifTrue: ["Internal pointer -- add segment offset"
mapOop := fieldOop + segmentWordArray]
ifFalse: ["External pointer -- look it up in outPointers"
outPtr := outPointerArray + (fieldOop bitAnd: 16r7FFFFFFF).
outPtr > lastOut ifTrue:
[^PrimErrBadIndex "out of bounds"].
mapOop := self longAt: outPtr].
doingClass
ifTrue: [self longAt: fieldPtr put: mapOop + hdrTypeBits.
fieldPtr := fieldPtr + 8.
doingClass := false]
ifFalse: [self longAt: fieldPtr put: mapOop.
+ fieldPtr := fieldPtr + self wordSize].
- fieldPtr := fieldPtr + BytesPerWord].
segOop < youngStart ifTrue:
[self possibleRootStoreInto: segOop value: mapOop]]].
segOop := self objectAfter: segOop].
"Again, proceed through the segment checking consistency..."
+ segOop := self oopFromChunk: segmentWordArray + self baseHeaderSize + self wordSize.
- segOop := self oopFromChunk: segmentWordArray + BaseHeaderSize + BytesPerWord.
[segOop <= endSeg] whileTrue:
[(self oopHasAcceptableClass: segOop) ifFalse:
[^PrimErrInappropriate "inconsistency"].
+ fieldPtr := segOop + self baseHeaderSize. "first field"
- fieldPtr := segOop + BaseHeaderSize. "first field"
lastPtr := segOop + (self lastPointerOf: segOop). "last field"
"Go through all oops, remapping them..."
[fieldPtr > lastPtr] whileFalse:
["Examine each pointer field"
fieldOop := self longAt: fieldPtr.
(self oopHasAcceptableClass: fieldOop) ifFalse:
[^PrimErrInappropriate "inconsistency"].
+ fieldPtr := fieldPtr + self wordSize].
- fieldPtr := fieldPtr + BytesPerWord].
segOop := self objectAfter: segOop].
"Truncate the segment word array to size = BytesPerWord (vers stamp only)"
extraSize := self extraHeaderBytes: segmentWordArray.
hdrTypeBits := self headerType: segmentWordArray.
extraSize = 8
+ ifTrue: [self longAt: segmentWordArray-extraSize put: self baseHeaderSize + self wordSize + hdrTypeBits]
- ifTrue: [self longAt: segmentWordArray-extraSize put: BaseHeaderSize + BytesPerWord + hdrTypeBits]
ifFalse: [header := self longAt: segmentWordArray.
self longAt: segmentWordArray
+ put: header - (header bitAnd: SizeMask) + self baseHeaderSize + self wordSize].
- put: header - (header bitAnd: SizeMask) + BaseHeaderSize + BytesPerWord].
"and return the roots array which was first in the segment"
DoAssertionChecks ifTrue: [self verifyCleanHeaders].
+ ^self oopFromChunk: segmentWordArray + self baseHeaderSize + self wordSize!
- ^self oopFromChunk: segmentWordArray + BaseHeaderSize + BytesPerWord!
Item was changed:
----- Method: NewObjectMemory>>maybeFillWithAllocationCheckFillerFrom:to: (in category 'allocation') -----
maybeFillWithAllocationCheckFillerFrom: start to: end
"Fill free memory with a bit pattern for checking if the last object has been overwritten."
<inline: true>
<var: 'start' type: #usqInt>
<var: 'end' type: #usqInt>
<var: 'p' type: #usqInt>
self checkAllocFiller ifTrue:
+ [start to: end by: self wordSize do:
- [start to: end by: BytesPerWord do:
[:p| self longAt: p put: p]]!
Item was changed:
----- Method: NewObjectMemory>>newObjectHash (in category 'allocation') -----
newObjectHash
"Derive the new object hash from the allocation pointer. This is less costly than
using lastHash because it avoids the read-modify-write cycle to update lastHash.
Since the size of eden is a power of two and larger than the hash range this provides
a well-distributed and fairly random set of values."
<inline: true>
+ ^freeStart >> self shiftForWord!
- ^freeStart >> ShiftForWord!
Item was changed:
----- Method: NewObjectMemory>>noteAsRoot:headerLoc: (in category 'garbage collection') -----
noteAsRoot: oop headerLoc: headerLoc
"Record that the given oop in the old object area points to an object in the young area.
HeaderLoc is usually = oop, but may be an addr in a forwarding block."
| header |
<inline: true>
- <asmLabel: false>
header := self longAt: headerLoc.
(self isYoungRootHeader: header) ifFalse:
"record oop as root only if not already recorded"
[rootTableCount < RootTableSize
ifTrue:
"record root if there is enough room in the roots table.
IMPORTANT: since clearRootsTable is the only thing that clears root bits
do *not* set the root bit unless an object is in the root table. checking
routines will complain about the root bit being unset instead of the table
being full, but that's life"
[rootTableCount := rootTableCount + 1.
rootTable at: rootTableCount put: oop.
self longAt: headerLoc put: (header bitOr: RootBit).
rootTableCount >= RootTableRedZone ifTrue:
"if we're now in the red zone force an IGC ASAP"
[self scheduleIncrementalGC]]
ifFalse: "note overflow; will need to do a fullGC instead of an incremental."
[rootTableOverflowed := true]]!
Item was changed:
----- Method: NewObjectMemory>>objectAfter: (in category 'object enumeration') -----
objectAfter: oop
"Return the object or free chunk immediately following the
given object or free chunk in memory. Return endOfMemory
when enumeration is complete."
| sz |
<api>
<inline: true>
- <asmLabel: false>
(self asserta: (self oop: oop isLessThan: freeStart)) ifFalse:
[self error: 'no objects after the end of memory'].
(self isFreeObject: oop)
ifTrue: [sz := self sizeOfFree: oop]
ifFalse: [sz := self sizeBitsOf: oop].
^self oopFromChunk: oop + sz!
Item was changed:
----- Method: NewObjectMemory>>okayOop: (in category 'debug support') -----
okayOop: signedOop
"Verify that the given oop is legitimate. Check address, header, and size but not class."
| sz type fmt unusedBit oop |
<var: #oop type: #usqInt>
oop := self cCoerce: signedOop to: #usqInt.
"address and size checks"
(self isIntegerObject: oop) ifTrue: [ ^true ].
(oop >= self startOfMemory and: [oop < freeStart])
ifFalse: [ self error: 'oop is not a valid address'. ^false ].
+ ((oop \\ self wordSize) = 0)
- ((oop \\ BytesPerWord) = 0)
ifFalse: [ self error: 'oop is not a word-aligned address'. ^false ].
sz := self sizeBitsOf: oop.
(oop + sz) <= freeStart
ifFalse: [ self error: 'oop size would make it extend beyond the end of memory'. ^false ].
"header type checks"
type := self headerType: oop.
type = HeaderTypeFree
ifTrue: [ self error: 'oop is a free chunk, not an object'. ^false ].
type = HeaderTypeShort ifTrue: [
(self compactClassIndexOf: oop) = 0
ifTrue: [ self error: 'cannot have zero compact class field in a short header'. ^false ].
].
type = HeaderTypeClass ifTrue: [
+ ((oop >= self wordSize) and: [(self headerType: oop - self wordSize) = type])
- ((oop >= BytesPerWord) and: [(self headerType: oop - BytesPerWord) = type])
ifFalse: [ self error: 'class header word has wrong type'. ^false ].
].
type = HeaderTypeSizeAndClass ifTrue: [
+ ((oop >= (self wordSize*2)) and:
+ [(self headerType: oop - (self wordSize*2)) = type and:
+ [(self headerType: oop - self wordSize) = type]])
- ((oop >= (BytesPerWord*2)) and:
- [(self headerType: oop - (BytesPerWord*2)) = type and:
- [(self headerType: oop - BytesPerWord) = type]])
ifFalse: [ self error: 'class header word has wrong type'. ^false ].
].
"format check"
fmt := self formatOf: oop.
((fmt = 5) | (fmt = 7))
ifTrue: [ self error: 'oop has an unknown format type'. ^false ].
"mark and root bit checks"
unusedBit := 16r20000000.
+ self wordSize = 8
- BytesPerWord = 8
ifTrue:
[unusedBit := unusedBit << 16.
unusedBit := unusedBit << 16].
((self longAt: oop) bitAnd: unusedBit) = 0
ifFalse: [ self error: 'unused header bit 30 is set; should be zero'. ^false ].
"xxx
((self longAt: oop) bitAnd: MarkBit) = 0
ifFalse: [ self error: 'mark bit should not be set except during GC' ].
xxx"
((self isYoungRoot: oop) and: [oop >= youngStart])
ifTrue: [ self error: 'root bit is set in a young object'. ^false ].
^true
!
Item was changed:
----- Method: NewObjectMemory>>prepareForwardingTableForBecoming:with:twoWay: (in category 'become') -----
prepareForwardingTableForBecoming: array1 with: array2 twoWay: twoWayFlag
"Ensure that there are enough forwarding blocks to
accomodate this become, then prepare forwarding blocks for
the pointer swap. Return true if successful."
"Details: Doing a GC might generate enough space for
forwarding blocks if we're short. However, this is an
uncommon enough case that it is better handled by primitive
fail code at the Smalltalk level."
"Important note on multiple references to same object - since the preparation of
fwdBlocks is NOT idempotent we get VM crashes if the same object is referenced more
than once in such a way as to require multiple fwdBlocks.
oop1 forwardBecome: oop1 is ok since only a single fwdBlock is needed.
oop1 become: oop1 would fail because the second fwdBlock woudl not have the actual object
header but rather the mutated ref to the first fwdBlock.
Further problems can arise with an array1 or array2 that refer multiply to the same
object. This would notbe expected input for programmer writen code but might arise from
automatic usage such as in ImageSegment loading.
To avoid the simple and rather common case of oop1 become*: oop1, we skip such pairs
and simply avoid making fwdBlocks - it is redundant anyway"
| entriesNeeded entriesAvailable fieldOffset oop1 oop2 fwdBlock fwdBlkSize |
+ entriesNeeded := (self lastPointerOf: array1) // self wordSize. "need enough entries for all oops"
- entriesNeeded := (self lastPointerOf: array1) // BytesPerWord. "need enough entries for all oops"
"Note: Forward blocks must be quadword aligned - see fwdTableInit:."
twoWayFlag
ifTrue: ["Double the number of blocks for two-way become"
entriesNeeded := entriesNeeded * 2.
+ fwdBlkSize := self wordSize * 2]
- fwdBlkSize := BytesPerWord * 2]
ifFalse: ["One-way become needs backPointers in fwd blocks."
+ fwdBlkSize := self wordSize * 4].
- fwdBlkSize := BytesPerWord * 4].
entriesAvailable := self fwdTableInit: fwdBlkSize.
entriesAvailable < entriesNeeded ifTrue:
[self initializeMemoryFirstFree: freeStart.
"re-initialize the free block"
^false].
fieldOffset := self lastPointerOf: array1.
+ [fieldOffset >= self baseHeaderSize] whileTrue:
- [fieldOffset >= BaseHeaderSize] whileTrue:
[oop1 := self longAt: array1 + fieldOffset.
oop2 := self longAt: array2 + fieldOffset.
"if oop1 == oop2, no need to do any work for this pair.
May still be other entries in the arrays though so keep looking"
oop1 ~= oop2 ifTrue:
[(self hasForwardingBlock: oop1) ifFalse: "Don't allocate multiple forwarding entries for duplicates."
[fwdBlock := self fwdBlockGet: fwdBlkSize.
self
initForwardBlock: fwdBlock
mapping: oop1
to: oop2
withBackPtr: twoWayFlag not].
(twoWayFlag
and: [(self hasForwardingBlock: oop2) not]) ifTrue: "Again don't get confused by duplicates"
["Second block maps oop2 back to oop1 for two-way become"
fwdBlock := self fwdBlockGet: fwdBlkSize.
self
initForwardBlock: fwdBlock
mapping: oop2
to: oop1
withBackPtr: twoWayFlag not]].
+ fieldOffset := fieldOffset - self wordSize].
- fieldOffset := fieldOffset - BytesPerWord].
^true!
Item was changed:
----- Method: NewObjectMemory>>printMemoryFrom:to: (in category 'printing') -----
printMemoryFrom: start to: end
<doNotGenerate>
| address |
+ address := start bitAnd: (self wordSize - 1) bitInvert.
- address := start bitAnd: (BytesPerWord - 1) bitInvert.
[address < end] whileTrue:
[coInterpreter printHex: address; printChar: $:; space; printHex: (self longAt: address); cr.
+ address := address + self wordSize]!
- address := address + BytesPerWord]!
Item was changed:
----- Method: NewObjectMemory>>restoreHeadersFrom:to:from:and:to:from: (in category 'image segment in/out') -----
restoreHeadersFrom: firstIn to: lastIn from: hdrBaseIn and: firstOut to: lastOut from: hdrBaseOut
"Restore headers smashed by forwarding links"
| tablePtr oop header |
tablePtr := firstIn.
[self oop: tablePtr isLessThanOrEqualTo: lastIn] whileTrue:
[oop := self longAt: tablePtr.
header := self longAt: hdrBaseIn + (tablePtr-firstIn).
self longAt: oop put: header.
+ tablePtr := tablePtr + self wordSize].
- tablePtr := tablePtr + BytesPerWord].
tablePtr := firstOut.
[self oop: tablePtr isLessThanOrEqualTo: lastOut] whileTrue:
[oop := self longAt: tablePtr.
header := self longAt: hdrBaseOut + (tablePtr-firstOut).
self longAt: oop put: header.
+ tablePtr := tablePtr + self wordSize].
- tablePtr := tablePtr + BytesPerWord].
"Clear all mark bits"
oop := self firstObject.
[self oop: oop isLessThan: freeStart] whileTrue:
[(self isFreeObject: oop) ifFalse:
[self longAt: oop put: ((self longAt: oop) bitAnd: AllButMarkBit)].
oop := self objectAfter: oop]!
Item was changed:
----- Method: NewObjectMemory>>safeObjectAfter: (in category 'object enumeration') -----
safeObjectAfter: oop
"Return the object or start of free space immediately following the
given object or free chunk in memory. Return freeStart when
enumeration is complete. This is for assertion checking only."
| sz |
- <asmLabel: false>
(self isFreeObject: oop)
ifTrue: [sz := self sizeOfFree: oop]
ifFalse: [sz := self sizeBitsOf: oop].
^(oop + sz) asUnsignedInteger >= freeStart
ifTrue: [freeStart]
ifFalse: [self oopFromChunk: oop + sz]!
Item was changed:
----- Method: NewObjectMemory>>safePrintStringOf: (in category 'debug printing') -----
safePrintStringOf: oop
"Version of printStringOf: that copes with forwarding during garbage collection."
| fmt header cnt i |
<inline: false>
(self isIntegerObject: oop) ifTrue:
[^nil].
(self oop: oop isGreaterThanOrEqualTo: self startOfMemory andLessThan: freeStart) ifFalse:
[^nil].
+ (oop bitAnd: (self wordSize - 1)) ~= 0 ifTrue:
- (oop bitAnd: (BytesPerWord - 1)) ~= 0 ifTrue:
[^nil].
header := self headerWhileForwardingOf: oop.
fmt := self formatOfHeader: header.
fmt < 8 ifTrue: [ ^nil ].
cnt := 100 min: (self lengthOf: oop baseHeader: header format: fmt).
i := 0.
[i < cnt] whileTrue:
[self printChar: (self fetchByte: i ofObject: oop).
i := i + 1].
coInterpreter flush.
^oop!
Item was changed:
----- Method: NewObjectMemory>>shorten:toIndexableSize: (in category 'allocation') -----
shorten: obj toIndexableSize: nSlots
"Reduce the number of indexable fields in obj, a pointer object, to nSlots. Convert the
unused residual to a free chunk. Word and byte indexable objects are not changed.
Answer the number of bytes returned to free memory, which may be zero if no change
was possible."
| deltaBytes desiredLength fixedFields fmt hdr totalLength
indexableFields |
(self isPointersNonImm: obj) ifFalse: [^0].
nSlots > 0
ifFalse: [^0]. "no change if nSlots is zero, error if nSlots is negative"
hdr := self baseHeader: obj.
fmt := self formatOfHeader: hdr.
totalLength := self lengthOf: obj baseHeader: hdr format: fmt.
fixedFields := self fixedFieldsOf: obj format: fmt length: totalLength.
indexableFields := totalLength - fixedFields.
nSlots >= indexableFields
ifTrue: [^0]. "no change, or error if attempting to increase size into next chunk"
desiredLength := fixedFields + nSlots.
+ deltaBytes := (totalLength - desiredLength) * self wordSize.
+ obj + self baseHeaderSize + (totalLength * self wordSize) = freeStart
- deltaBytes := (totalLength - desiredLength) * BytesPerWord.
- obj + BaseHeaderSize + (totalLength * BytesPerWord) = freeStart
ifTrue: "Shortening the last object. Need to reduce freeStart."
+ [self maybeFillWithAllocationCheckFillerFrom: obj + self baseHeaderSize + (desiredLength * self wordSize) to: freeStart.
+ freeStart := obj + self baseHeaderSize + (desiredLength * self wordSize)]
- [self maybeFillWithAllocationCheckFillerFrom: obj + BaseHeaderSize + (desiredLength * BytesPerWord) to: freeStart.
- freeStart := obj + BaseHeaderSize + (desiredLength * BytesPerWord)]
ifFalse: "Shortening some interior object. Need to create a free block."
+ [self setSizeOfFree: obj + self baseHeaderSize + (desiredLength * self wordSize)
- [self setSizeOfFree: obj + BaseHeaderSize + (desiredLength * BytesPerWord)
to: deltaBytes].
(self headerType: obj) caseOf: {
[HeaderTypeSizeAndClass] ->
+ [self longAt: (obj - (self baseHeaderSize * 2)) put: (self sizeHeader: obj) - deltaBytes].
- [self longAt: (obj - (BaseHeaderSize * 2)) put: (self sizeHeader: obj) - deltaBytes].
[HeaderTypeClass] ->
[self longAt: obj put: ((hdr bitClear: SizeMask) bitOr: (hdr bitAnd: SizeMask) - deltaBytes)].
[HeaderTypeShort] ->
[self longAt: obj put: ((hdr bitClear: SizeMask) bitOr: (hdr bitAnd: SizeMask) - deltaBytes)] }.
^deltaBytes!
Item was changed:
----- Method: NewObjectMemory>>sizeHeader:putBodySize: (in category 'primitive support') -----
sizeHeader: obj putBodySize: byteSize
"Too lazy to set the odd bits right now. Just insist on a multiple of 4 bytes."
self assert: byteSize \\ 4 = 0.
+ self longAt: obj - (self wordSize*2)
+ put: ((byteSize + self wordSize bitAnd: LongSizeMask)
+ bitOr: ((self longAt: obj - (self wordSize*2)) bitClear: LongSizeMask))!
- self longAt: obj - (BytesPerWord*2)
- put: ((byteSize + BytesPerWord bitAnd: LongSizeMask)
- bitOr: ((self longAt: obj - (BytesPerWord*2)) bitClear: LongSizeMask))!
Item was changed:
----- Method: NewObjectMemory>>storeImageSegmentInto:outPointers:roots: (in category 'image segment in/out') -----
storeImageSegmentInto: segmentWordArray outPointers: outPointerArray roots: arrayOfRoots
"This primitive will store a binary image segment (in the same format as the Squeak image file) of the receiver and every object in its proper tree of subParts (ie, that is not refered to from anywhere else outside the tree). All pointers from within the tree to objects outside the tree will be copied into the array of outpointers. In their place in the image segment will be an oop equal to the offset in the outPointer array (the first would be 4). but with the high bit set."
"The primitive expects the array and wordArray to be more than adequately long. In this case it returns normally, and truncates the two arrays to exactly the right size. To simplify truncation, both incoming arrays are required to be 256 bytes or more long (ie with 3-word headers). If either array is too small, the primitive will fail, but in no other case.
During operation of the primitive, it is necessary to convert from both internal and external oops to their mapped values. To make this fast, the headers of the original objects in question are replaced by the mapped values (and this is noted by adding the forbidden XX header type). Tables are kept of both kinds of oops, as well as of the original headers for restoration.
To be specific, there are two similar two-part tables, the outpointer array, and one in the upper fifth of the segmentWordArray. Each grows oops from the bottom up, and preserved headers from halfway up.
In case of either success or failure, the headers must be restored. In the event of primitive failure, the table of outpointers must also be nilled out (since the garbage in the high half will not have been discarded."
| savedYoungStart lastOut lastIn firstIn lastSeg endSeg segOop fieldPtr fieldOop mapOop
doingClass lastPtr extraSize hdrTypeBits hdrBaseIn hdrBaseOut header firstOut versionOffset |
<inline: false>
<var: #firstIn type: #usqInt>
<var: #lastIn type: #usqInt>
<var: #firstOut type: #usqInt>
<var: #lastOut type: #usqInt>
<var: #hdrBaseIn type: #usqInt>
<var: #hdrBaseOut type: #usqInt>
<var: #lastSeg type: #usqInt>
<var: #endSeg type: #usqInt>
<var: #fieldPtr type: #usqInt>
<var: #lastPtr type: #usqInt>
<var: #segOop type: #usqInt>
<var: #savedYoungStart type: #usqInt>
((self headerType: outPointerArray) = HeaderTypeSizeAndClass "Must be 3-word header"
and: [(self headerType: segmentWordArray) = HeaderTypeSizeAndClass]) "Must be 3-word header"
ifFalse: [^PrimErrGenericFailure].
DoAssertionChecks ifTrue: [self verifyCleanHeaders].
"Use the top half of outPointers for saved headers."
+ firstOut := outPointerArray + self baseHeaderSize.
+ lastOut := firstOut - self wordSize.
+ hdrBaseOut := outPointerArray + ((self lastPointerOf: outPointerArray) // (self wordSize*2) * self wordSize). "top half"
- firstOut := outPointerArray + BaseHeaderSize.
- lastOut := firstOut - BytesPerWord.
- hdrBaseOut := outPointerArray + ((self lastPointerOf: outPointerArray) // (BytesPerWord*2) * BytesPerWord). "top half"
lastSeg := segmentWordArray.
+ endSeg := segmentWordArray + (self sizeBitsOf: segmentWordArray) - self wordSize.
- endSeg := segmentWordArray + (self sizeBitsOf: segmentWordArray) - BytesPerWord.
"Write a version number for byte order and version check"
+ versionOffset := self wordSize.
- versionOffset := BytesPerWord.
lastSeg := lastSeg + versionOffset.
lastSeg > endSeg ifTrue: [^PrimErrGenericFailure].
self longAt: lastSeg put: self imageSegmentVersion.
"Allocate top 1/8 of segment for table of internal oops and saved headers"
+ firstIn := endSeg - ((self sizeBitsOf: segmentWordArray) // (self wordSize*8) * self wordSize). "Take 1/8 of seg"
+ lastIn := firstIn - self wordSize.
+ hdrBaseIn := firstIn + ((self sizeBitsOf: segmentWordArray) // (self wordSize*16) * self wordSize). "top half of that"
- firstIn := endSeg - ((self sizeBitsOf: segmentWordArray) // (BytesPerWord*8) * BytesPerWord). "Take 1/8 of seg"
- lastIn := firstIn - BytesPerWord.
- hdrBaseIn := firstIn + ((self sizeBitsOf: segmentWordArray) // (BytesPerWord*16) * BytesPerWord). "top half of that"
"First mark the rootArray and all root objects."
self longAt: arrayOfRoots put: ((self longAt: arrayOfRoots) bitOr: MarkBit).
lastPtr := arrayOfRoots + (self lastPointerOf: arrayOfRoots).
+ fieldPtr := arrayOfRoots + self baseHeaderSize.
- fieldPtr := arrayOfRoots + BaseHeaderSize.
[fieldPtr <= lastPtr] whileTrue:
[fieldOop := self longAt: fieldPtr.
(self isIntegerObject: fieldOop) ifFalse:
[self longAt: fieldOop put: ((self longAt: fieldOop) bitOr: MarkBit)].
+ fieldPtr := fieldPtr + self wordSize].
- fieldPtr := fieldPtr + BytesPerWord].
"Then do a mark pass over all objects. This will stop at our marked roots,
thus leaving our segment unmarked in their shadow."
savedYoungStart := youngStart.
youngStart := self startOfMemory. "process all of memory"
self markAndTraceInterpreterOops: false. "and special objects array"
youngStart := savedYoungStart.
"Finally unmark the rootArray and all root objects."
self longAt: arrayOfRoots put: ((self longAt: arrayOfRoots) bitAnd: AllButMarkBit).
+ fieldPtr := arrayOfRoots + self baseHeaderSize.
- fieldPtr := arrayOfRoots + BaseHeaderSize.
[fieldPtr <= lastPtr] whileTrue:
[fieldOop := self longAt: fieldPtr.
(self isIntegerObject: fieldOop) ifFalse:
[self longAt: fieldOop put: ((self longAt: fieldOop) bitAnd: AllButMarkBit)].
+ fieldPtr := fieldPtr + self wordSize].
- fieldPtr := fieldPtr + BytesPerWord].
"All external objects, and only they, are now marked.
Copy the array of roots into the segment, and forward its oop."
+ lastIn := lastIn + self wordSize.
- lastIn := lastIn + BytesPerWord.
(lastIn >= hdrBaseIn
or: [0 = (lastSeg := self copyObj: arrayOfRoots toSegment: segmentWordArray addr: lastSeg stopAt: firstIn saveOopAt: lastIn headerAt: hdrBaseIn + (lastIn - firstIn))]) ifTrue:
+ [lastIn := lastIn - self wordSize.
- [lastIn := lastIn - BytesPerWord.
self restoreHeadersFrom: firstIn to: lastIn from: hdrBaseIn and: firstOut to: lastOut from: hdrBaseOut.
^self primitiveFailCodeAfterCleanup: outPointerArray].
"Now run through the segment fixing up all the pointers.
Note that more objects will be added to the segment as we make our way along."
+ segOop := self oopFromChunk: segmentWordArray + versionOffset + self baseHeaderSize.
- segOop := self oopFromChunk: segmentWordArray + versionOffset + BaseHeaderSize.
[segOop <= lastSeg] whileTrue:
[(self headerType: segOop) <= 1
ifTrue: ["This object has a class field (type=0 or 1) -- start with that."
+ fieldPtr := segOop - self wordSize. doingClass := true]
- fieldPtr := segOop - BytesPerWord. doingClass := true]
ifFalse: ["No class field -- start with first data field"
+ fieldPtr := segOop + self baseHeaderSize. doingClass := false].
- fieldPtr := segOop + BaseHeaderSize. doingClass := false].
lastPtr := segOop + (self lastPointerOf: segOop). "last field"
"Go through all oops, remapping them..."
[fieldPtr > lastPtr] whileFalse:
["Examine each pointer field"
fieldOop := self longAt: fieldPtr.
doingClass ifTrue:
[hdrTypeBits := fieldOop bitAnd: TypeMask.
fieldOop := fieldOop - hdrTypeBits].
(self isIntegerObject: fieldOop)
ifTrue: ["Just an integer -- nothing to do"
+ fieldPtr := fieldPtr + self wordSize]
- fieldPtr := fieldPtr + BytesPerWord]
ifFalse:
[header := self longAt: fieldOop.
(header bitAnd: TypeMask) = HeaderTypeFree
ifTrue: ["Has already been forwarded -- this is the link"
mapOop := header bitAnd: AllButTypeMask]
ifFalse:
[((self longAt: fieldOop) bitAnd: MarkBit) = 0
ifTrue:
["Points to an unmarked obj -- an internal pointer.
Copy the object into the segment, and forward its oop."
+ lastIn := lastIn + self wordSize.
- lastIn := lastIn + BytesPerWord.
(lastIn >= hdrBaseIn
or: [0 = (lastSeg := self copyObj: fieldOop toSegment: segmentWordArray addr: lastSeg stopAt: firstIn saveOopAt: lastIn headerAt: hdrBaseIn + (lastIn - firstIn))]) ifTrue:
["Out of space in segment"
+ lastIn := lastIn - self wordSize.
- lastIn := lastIn - BytesPerWord.
self restoreHeadersFrom: firstIn to: lastIn from: hdrBaseIn and: firstOut to: lastOut from: hdrBaseOut.
^self primitiveFailCodeAfterCleanup: outPointerArray].
mapOop := (self longAt: fieldOop) bitAnd: AllButTypeMask]
ifFalse:
["Points to a marked obj -- an external pointer.
Map it as a tagged index in outPointers, and forward its oop."
+ lastOut := lastOut + self wordSize.
- lastOut := lastOut + BytesPerWord.
lastOut >= hdrBaseOut ifTrue:
["Out of space in outPointerArray"
+ lastOut := lastOut - self wordSize.
- lastOut := lastOut - BytesPerWord.
self restoreHeadersFrom: firstIn to: lastIn from: hdrBaseIn and: firstOut to: lastOut from: hdrBaseOut.
^self primitiveFailCodeAfterCleanup: outPointerArray].
. mapOop := lastOut - outPointerArray bitOr: 16r80000000.
self forward: fieldOop to: mapOop
savingOopAt: lastOut andHeaderAt: hdrBaseOut + (lastOut - firstOut)]].
"Replace the oop by its mapped value"
doingClass
ifTrue: [self longAt: fieldPtr put: mapOop + hdrTypeBits.
+ fieldPtr := fieldPtr + (self wordSize*2).
- fieldPtr := fieldPtr + (BytesPerWord*2).
doingClass := false]
ifFalse: [self longAt: fieldPtr put: mapOop.
+ fieldPtr := fieldPtr + self wordSize]]].
- fieldPtr := fieldPtr + BytesPerWord]]].
segOop := self objectAfter: segOop].
self restoreHeadersFrom: firstIn to: lastIn from: hdrBaseIn and: firstOut to: lastOut from: hdrBaseOut.
"Truncate the outPointerArray..."
((outPointerArray + (self lastPointerOf: outPointerArray) - lastOut) < 12
or: [(endSeg - lastSeg) < 12]) ifTrue:
["Not enough room to insert simple 3-word headers"
^self primitiveFailCodeAfterCleanup: outPointerArray].
extraSize := self extraHeaderBytes: segmentWordArray.
hdrTypeBits := self headerType: segmentWordArray.
"Copy the 3-word wordArray header to establish a free chunk."
self transfer: 3
from: segmentWordArray - extraSize
+ to: lastOut+self wordSize.
- to: lastOut+BytesPerWord.
"Adjust the size of the original as well as the free chunk."
+ self longAt: lastOut+self wordSize
- self longAt: lastOut+BytesPerWord
put: outPointerArray + (self lastPointerOf: outPointerArray) - lastOut - extraSize + hdrTypeBits.
self longAt: outPointerArray-extraSize
+ put: lastOut - firstOut + (self wordSize*2) + hdrTypeBits.
- put: lastOut - firstOut + (BytesPerWord*2) + hdrTypeBits.
"Note that pointers have been stored into roots table"
self beRootIfOld: outPointerArray.
"Truncate the image segment..."
"Copy the 3-word wordArray header to establish a free chunk."
self transfer: 3
from: segmentWordArray - extraSize
+ to: lastSeg+self wordSize.
- to: lastSeg+BytesPerWord.
"Adjust the size of the original as well as the free chunk."
self longAt: segmentWordArray-extraSize
+ put: lastSeg - segmentWordArray + self baseHeaderSize + hdrTypeBits.
+ self longAt: lastSeg+self wordSize
- put: lastSeg - segmentWordArray + BaseHeaderSize + hdrTypeBits.
- self longAt: lastSeg+BytesPerWord
put: endSeg - lastSeg - extraSize + hdrTypeBits.
DoAssertionChecks ifTrue: [self verifyCleanHeaders].
^PrimNoErr!
Item was changed:
----- Method: NewObjectMemory>>sufficientSpaceToAllocate: (in category 'allocation') -----
sufficientSpaceToAllocate: bytes
"Return true if there is enough space to allocate the given number of bytes, perhaps after doing a garbage collection."
| minFree |
<inline: true>
+ minFree := (lowSpaceThreshold + bytes + self baseHeaderSize + self wordSize - 1) bitClear: self wordSize - 1.
- minFree := (lowSpaceThreshold + bytes + BaseHeaderSize + BytesPerWord - 1) bitClear: BytesPerWord - 1.
"check for low-space"
(self oop: freeStart + minFree isLessThanOrEqualTo: reserveStart) ifTrue:
[^true].
^self sufficientSpaceAfterGC: minFree!
Item was changed:
----- Method: NewObjectMemory>>sweepPhase (in category 'gc -- mark and sweep') -----
sweepPhase
"Sweep memory from youngStart through the end of memory. Free all
inaccessible objects and coalesce adjacent free chunks. Clear the mark
bits of accessible objects. Compute the starting point for the first pass of
incremental compaction (compStart). Return the number of surviving
objects. "
"Details: Each time a non-free object is encountered, decrement the
number of available forward table entries. If all entries are spoken for
(i.e., entriesAvailable reaches zero), set compStart to the last free
chunk before that object or, if there is no free chunk before the given
object, the first free chunk after it. Thus, at the end of the sweep
phase, compStart through compEnd spans the highest collection of
non-free objects that can be accomodated by the forwarding table. This
information is used by the first pass of incremental compaction to
ensure that space is initially freed at the end of memory. Note that
there should always be at least one free chunk--the one at the end of
the heap."
| entriesAvailable survivors freeChunk firstFree oop oopHeader oopHeaderType hdrBytes oopSize freeChunkSize freeStartLocal |
<inline: false>
<var: #oop type: #usqInt>
<var: #freeStartLocal type: #usqInt>
+ entriesAvailable := self fwdTableInit: self wordSize*2.
- entriesAvailable := self fwdTableInit: BytesPerWord*2.
survivors := 0.
freeChunk := nil.
firstFree := nil.
"will be updated later"
freeStartLocal := freeStart.
oop := self oopFromChunk: youngStart.
[oop < freeStartLocal]
whileTrue: ["get oop's header, header type, size, and header size"
statSweepCount := statSweepCount + 1.
oopHeader := self baseHeader: oop.
oopHeaderType := oopHeader bitAnd: TypeMask.
hdrBytes := headerTypeBytes at: oopHeaderType.
(oopHeaderType bitAnd: 1) = 1
ifTrue: [oopSize := oopHeader bitAnd: SizeMask]
ifFalse: [oopHeaderType = HeaderTypeSizeAndClass
ifTrue: [oopSize := (self sizeHeader: oop) bitAnd: LongSizeMask]
ifFalse: ["free chunk" oopSize := oopHeader bitAnd: LongSizeMask]].
(oopHeader bitAnd: MarkBit) = 0
ifTrue: ["object is not marked; free it"
"<-- Finalization support: We need to mark each oop chunk as free -->"
self longAt: oop - hdrBytes put: HeaderTypeFree.
freeChunk ~= nil
ifTrue: ["enlarge current free chunk to include this oop"
freeChunkSize := freeChunkSize + oopSize + hdrBytes]
ifFalse: ["start a new free chunk"
freeChunk := oop - hdrBytes.
"chunk may start 4 or 8 bytes before oop"
freeChunkSize := oopSize + (oop - freeChunk).
"adjust size for possible extra header bytes"
firstFree = nil ifTrue: [firstFree := freeChunk]]]
ifFalse: ["object is marked; clear its mark bit and possibly adjust
the compaction start"
self longAt: oop put: (oopHeader bitAnd: AllButMarkBit).
"<-- Finalization support: Check if we're running about a weak class -->"
(self isWeakNonImm: oop) ifTrue: [self finalizeReference: oop].
entriesAvailable > 0
ifTrue: [entriesAvailable := entriesAvailable - 1]
ifFalse: ["start compaction at the last free chunk before this object"
firstFree := freeChunk].
freeChunk ~= nil
ifTrue: ["record the size of the last free chunk"
self longAt: freeChunk put: ((freeChunkSize bitAnd: LongSizeMask) bitOr: HeaderTypeFree).
freeChunk := nil].
survivors := survivors + 1].
oopSize = 0 ifTrue:
[self error: 'zero sized object encountered in sweep'].
oop := self oopFromChunk: oop + oopSize].
freeChunk ~= nil
ifTrue: ["record size of final free chunk"
self longAt: freeChunk put: ((freeChunkSize bitAnd: LongSizeMask) bitOr: HeaderTypeFree)].
oop = freeStart
ifFalse: [self error: 'sweep failed to find exact end of memory'].
compStart := firstFree = nil
ifTrue: [freeStart]
ifFalse: [firstFree].
^survivors!
Item was changed:
----- Method: NewObjectMemory>>sweepPhaseForFullGC (in category 'garbage collection') -----
sweepPhaseForFullGC
"Sweep memory from youngStart through the end of memory. Free all
inaccessible objects and coalesce adjacent free chunks. Clear the mark
bits of accessible objects. Compute the starting point for the first pass
of incremental compaction (compStart). Return the number of surviving
objects. Unlike sweepPhase this always leaves compStart pointing at the
first free chunk."
| survivors freeChunk firstFree oop oopHeader oopHeaderType hdrBytes oopSize freeChunkSize endOfMemoryLocal |
<inline: false>
<var: #oop type: #usqInt>
<var: #endOfMemoryLocal type: #usqInt>
+ self fwdTableInit: self wordSize*2.
- self fwdTableInit: BytesPerWord*2.
survivors := 0.
freeChunk := nil.
firstFree := nil.
"will be updated later"
endOfMemoryLocal := endOfMemory.
oop := self oopFromChunk: youngStart.
[oop < endOfMemoryLocal]
whileTrue: ["get oop's header, header type, size, and header size"
statSweepCount := statSweepCount + 1.
oopHeader := self baseHeader: oop.
oopHeaderType := oopHeader bitAnd: TypeMask.
hdrBytes := headerTypeBytes at: oopHeaderType.
(oopHeaderType bitAnd: 1) = 1
ifTrue: [oopSize := oopHeader bitAnd: SizeMask]
ifFalse: [oopHeaderType = HeaderTypeSizeAndClass
ifTrue: [oopSize := (self sizeHeader: oop) bitAnd: LongSizeMask]
ifFalse: [self assert: (oopHeader bitAnd: MarkBit) = 0.
oopSize := oopHeader bitAnd: LongSizeMask]].
(oopHeader bitAnd: MarkBit) = 0
ifTrue: ["object is not marked; free it"
"<-- Finalization support: We need to mark each oop chunk as free -->"
self longAt: oop - hdrBytes put: HeaderTypeFree.
freeChunk ~= nil
ifTrue: ["enlarge current free chunk to include this oop"
freeChunkSize := freeChunkSize + oopSize + hdrBytes]
ifFalse: ["start a new free chunk"
freeChunk := oop - hdrBytes.
"chunk may start 4 or 8 bytes before oop"
freeChunkSize := oopSize + (oop - freeChunk).
"adjust size for possible extra header bytes"
firstFree = nil ifTrue: [firstFree := freeChunk]]]
ifFalse: ["object is marked; clear its mark bit and possibly adjust
the compaction start"
self longAt: oop put: (oopHeader bitAnd: AllButMarkBit).
"<-- Finalization support: Check if we're running about a weak class -->"
(self isWeakNonImm: oop) ifTrue: [self finalizeReference: oop].
freeChunk ~= nil
ifTrue: ["record the size of the last free chunk"
self longAt: freeChunk put: ((freeChunkSize bitAnd: LongSizeMask) bitOr: HeaderTypeFree).
freeChunk := nil].
survivors := survivors + 1].
oop := self oopFromChunk: oop + oopSize].
freeChunk ~= nil
ifTrue: ["record size of final free chunk"
self longAt: freeChunk put: ((freeChunkSize bitAnd: LongSizeMask) bitOr: HeaderTypeFree)].
oop = endOfMemory
ifTrue: [freeStart := endOfMemory]
ifFalse: [self error: 'sweep failed to find exact end of memory'].
firstFree = nil
ifTrue: [self error: 'expected to find at least one free object']
ifFalse: [compStart := firstFree].
^ survivors!
Item was changed:
----- Method: NewObjectMemory>>validate: (in category 'simulation') -----
validate: oop
<doNotGenerate>
| header type cc sz fmt nextChunk |
header := self longAt: oop.
type := header bitAnd: 3.
type = 2 ifFalse: [type = (self rightType: header) ifFalse: [self halt]].
sz := (header bitAnd: SizeMask) >> 2.
nextChunk := oop + ((self isFreeObject: oop)
ifTrue: [self sizeOfFree: oop]
ifFalse: [self sizeBitsOf: oop]).
nextChunk >= freeStart
ifTrue:
[nextChunk ~= freeStart ifTrue: [self halt]]
ifFalse:
[(self headerType: nextChunk) = 0 ifTrue:
+ [(self headerType: (nextChunk + (self wordSize*2))) = 0 ifFalse: [self halt]].
- [(self headerType: (nextChunk + (BytesPerWord*2))) = 0 ifFalse: [self halt]].
(self headerType: nextChunk) = 1 ifTrue:
+ [(self headerType: (nextChunk + self wordSize)) = 1 ifFalse: [self halt]]].
- [(self headerType: (nextChunk + BytesPerWord)) = 1 ifFalse: [self halt]]].
type = 2 ifTrue: "free block"
[^self].
fmt := self formatOfHeader: header.
cc := self compactClassIndexOfHeader: header.
cc > 16 ifTrue: [self halt]. "up to 32 are legal, but not used"
type = 0 ifTrue:
["three-word header"
+ ((self longAt: oop-self wordSize) bitAnd: 3) = type ifFalse: [self halt].
+ ((self longAt: oop-(self wordSize*2)) bitAnd: 3) = type ifFalse: [self halt].
+ ((self longAt: oop-self wordSize) = type) ifTrue: [self halt]. "Class word is 0"
- ((self longAt: oop-BytesPerWord) bitAnd: 3) = type ifFalse: [self halt].
- ((self longAt: oop-(BytesPerWord*2)) bitAnd: 3) = type ifFalse: [self halt].
- ((self longAt: oop-BytesPerWord) = type) ifTrue: [self halt]. "Class word is 0"
sz = 0 ifFalse: [self halt]].
type = 1 ifTrue:
["two-word header"
+ ((self longAt: oop-self wordSize) bitAnd: 3) = type ifFalse: [self halt].
- ((self longAt: oop-BytesPerWord) bitAnd: 3) = type ifFalse: [self halt].
cc > 0 ifTrue: [sz = 1 ifFalse: [self halt]].
sz = 0 ifTrue: [self halt]].
type = 3 ifTrue:
["one-word header"
cc = 0 ifTrue: [self halt]].
fmt = 5 ifTrue: [self halt].
fmt = 7 ifTrue: [self halt].
fmt >= self firstCompiledMethodFormat ifTrue: "must have integer header"
+ [(self isIntegerObject: (self longAt: oop + self wordSize)) ifFalse: [self halt]].!
- [(self isIntegerObject: (self longAt: oop + BytesPerWord)) ifFalse: [self halt]].!
Item was changed:
----- Method: NewObjectMemory>>wordSwapFloatsFrom:to: (in category 'image segment in/out') -----
wordSwapFloatsFrom: startOop to: stopAddr
"Swap the most and least significant words of Floats in a range of the image."
| oop temp |
oop := startOop.
[self oop: oop isLessThan: stopAddr] whileTrue:
[(self isFreeObject: oop) ifFalse:
[((self formatOf: oop) = self firstLongFormat
and: [(self 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 + BaseHeaderSize.
- self longAt: oop + BaseHeaderSize put: (self longAt: oop + BaseHeaderSize + 4).
- self longAt: oop + BaseHeaderSize + 4 put: temp]].
oop := self objectAfter: oop]!
Item was added:
+ ----- Method: NewObjectMemorySimulator>>baseHeaderSize (in category 'memory access') -----
+ baseHeaderSize
+ ^4!
Item was added:
+ ----- Method: NewObjectMemorySimulator>>bytesPerOop (in category 'memory access') -----
+ bytesPerOop
+ ^4!
Item was changed:
----- Method: NewObjectMemorySimulator>>firstIndexableField: (in category 'simulation only') -----
firstIndexableField: oop
"NOTE: overridden from ObjectMemory to add coercion to CArray, so please duplicate any changes"
| hdr fmt totalLength fixedFields |
<returnTypeC: #'void *'>
hdr := self baseHeader: oop.
fmt := self formatOfHeader: hdr.
fmt <= self lastPointerFormat ifTrue:
["pointer; may need to delve into the class format word"
totalLength := self lengthOf: oop baseHeader: hdr format: fmt.
fixedFields := self fixedFieldsOf: oop format: fmt length: totalLength.
+ ^self cCoerce: (self pointerForOop: oop + self baseHeaderSize + (fixedFields << self shiftForWord)) to: 'oop *'].
- ^self cCoerce: (self pointerForOop: oop + BaseHeaderSize + (fixedFields << ShiftForWord)) to: 'oop *'].
^self
+ cCoerce: (self pointerForOop: oop + self baseHeaderSize)
- cCoerce: (self pointerForOop: oop + BaseHeaderSize)
to: (fmt < self firstByteFormat
ifTrue: [fmt = self firstLongFormat
ifTrue: ["32 bit field objects" 'int *']
ifFalse: ["full word objects (bits)" 'oop *']]
ifFalse: ["byte objects (including CompiledMethod" 'char *'])!
Item was added:
+ ----- Method: NewObjectMemorySimulator>>wordSize (in category 'memory access') -----
+ wordSize
+ ^4!
Item was changed:
----- Method: NewObjectMemorySimulatorLSB>>nextLongFrom: (in category 'initialization') -----
nextLongFrom: aStream
"Read a 32- or 64-bit quantity from the given (binary) stream."
+ ^ aStream nextLittleEndianNumber: self wordSize!
- ^ aStream nextLittleEndianNumber: BytesPerWord!
Item was changed:
----- Method: NewObjectMemorySimulatorMSB>>byteAt: (in category 'memory access') -----
byteAt: byteAddress
| lowBits bpwMinus1 |
+ bpwMinus1 := self wordSize-1.
- bpwMinus1 := BytesPerWord-1.
lowBits := byteAddress bitAnd: bpwMinus1.
^ ((self longAt: byteAddress - lowBits)
bitShift: (lowBits - bpwMinus1) * 8)
bitAnd: 16rFF!
Item was changed:
----- Method: NewObjectMemorySimulatorMSB>>byteAt:put: (in category 'memory access') -----
byteAt: byteAddress put: byte
| longWord shift lowBits bpwMinus1 longAddress |
+ bpwMinus1 := self wordSize-1.
- bpwMinus1 := BytesPerWord-1.
lowBits := byteAddress bitAnd: bpwMinus1.
longAddress := byteAddress - lowBits.
longWord := self longAt: longAddress.
shift := (bpwMinus1 - lowBits) * 8.
longWord := longWord
- (longWord bitAnd: (16rFF bitShift: shift))
+ (byte bitShift: shift).
self assert: longAddress < freeStart.
self longAt: longAddress put: longWord.
^byte!
Item was changed:
----- Method: NewObjectMemorySimulatorMSB>>charsOfLong: (in category 'debug support') -----
charsOfLong: long
+ ^ (self wordSize to: 1 by: -1) collect:
- ^ (BytesPerWord to: 1 by: -1) collect:
[:i | ((long digitAt: i) between: 14 and: 126)
ifTrue: [(long digitAt: i) asCharacter]
ifFalse: [$?]]!
Item was changed:
----- Method: NewObjectMemorySimulatorMSB>>nextLongFrom: (in category 'image save/restore') -----
nextLongFrom: aStream
"Read a 32- or 64-bit quantity from the given (binary) stream."
+ ^ aStream nextNumber: self wordSize!
- ^ aStream nextNumber: BytesPerWord!
Item was changed:
----- Method: NewObjectMemorySimulatorMSB>>shortAt: (in category 'memory access') -----
shortAt: byteAddress
"Return the half-word at byteAddress which must be even."
| lowBits bpwMinus2 |
+ bpwMinus2 := self wordSize-2.
- bpwMinus2 := BytesPerWord-2.
lowBits := byteAddress bitAnd: bpwMinus2.
^ ((self longAt: byteAddress - lowBits)
bitShift: (lowBits - bpwMinus2) * 8)
bitAnd: 16rFFFF
!
Item was changed:
----- Method: NewObjectMemorySimulatorMSB>>shortAt:put: (in category 'memory access') -----
shortAt: byteAddress put: a16BitValue
"Return the half-word at byteAddress which must be even."
| longWord shift lowBits bpwMinus2 longAddress |
+ bpwMinus2 := self wordSize-2.
- bpwMinus2 := BytesPerWord-2.
lowBits := byteAddress bitAnd: bpwMinus2.
longAddress := byteAddress - lowBits.
longWord := self longAt: longAddress.
shift := (bpwMinus2 - lowBits) * 8.
longWord := longWord
- (longWord bitAnd: (16rFFFF bitShift: shift))
+ (a16BitValue bitShift: shift).
self longAt: longAddress put: longWord
!
Item was changed:
----- Method: NewspeakInterpreter>>activateNewClosureMethod: (in category 'control primitives') -----
activateNewClosureMethod: blockClosure
"Similar to activateNewMethod but for Closure and newMethod."
| theBlockClosure closureMethod newContext methodHeader numCopied where outerContext |
DoAssertionChecks ifTrue:
[self okayOop: blockClosure].
outerContext := self fetchPointer: ClosureOuterContextIndex ofObject: blockClosure.
DoAssertionChecks ifTrue:
[self okayOop: outerContext].
closureMethod := self fetchPointer: MethodIndex ofObject: outerContext.
methodHeader := self methodHeaderOf: closureMethod.
self pushRemappableOop: blockClosure.
newContext := self allocateOrRecycleContext: (methodHeader bitAnd: LargeContextBit). "All for one, and one for all!!"
"allocateOrRecycleContext: may cause a GC; restore blockClosure and refetch outerContext et al"
theBlockClosure := self popRemappableOop.
outerContext := self fetchPointer: ClosureOuterContextIndex ofObject: theBlockClosure.
numCopied := (self numSlotsOf: theBlockClosure) - ClosureFirstCopiedValueIndex.
"Assume: newContext will be recorded as a root if necessary by the
call to newActiveContext: below, so we can use unchecked stores."
+ where := newContext + self baseHeaderSize.
+ self longAt: where + (SenderIndex << self shiftForWord)
- where := newContext + BaseHeaderSize.
- self longAt: where + (SenderIndex << ShiftForWord)
put: activeContext.
+ self longAt: where + (InstructionPointerIndex << self shiftForWord)
- self longAt: where + (InstructionPointerIndex << ShiftForWord)
put: (self fetchPointer: ClosureStartPCIndex ofObject: theBlockClosure).
+ self longAt: where + (StackPointerIndex << self shiftForWord)
- self longAt: where + (StackPointerIndex << ShiftForWord)
put: (self integerObjectOf: argumentCount + numCopied).
+ self longAt: where + (MethodIndex << self shiftForWord)
- self longAt: where + (MethodIndex << ShiftForWord)
put: (self fetchPointer: MethodIndex ofObject: outerContext).
+ self longAt: where + (ClosureIndex << self shiftForWord)
- self longAt: where + (ClosureIndex << ShiftForWord)
put: theBlockClosure.
+ self longAt: where + (ReceiverIndex << self shiftForWord)
- self longAt: where + (ReceiverIndex << ShiftForWord)
put: (self fetchPointer: ReceiverIndex ofObject: outerContext).
"Copy the arguments..."
1 to: argumentCount do:
+ [:i | self longAt: where + ((ReceiverIndex+i) << self shiftForWord)
- [:i | self longAt: where + ((ReceiverIndex+i) << ShiftForWord)
put: (self stackValue: argumentCount-i)].
"Copy the copied values..."
+ where := newContext + self baseHeaderSize + ((ReceiverIndex + 1 + argumentCount) << self shiftForWord).
- where := newContext + BaseHeaderSize + ((ReceiverIndex + 1 + argumentCount) << ShiftForWord).
0 to: numCopied - 1 do:
+ [:i| self longAt: where + (i << self shiftForWord)
- [:i| self longAt: where + (i << ShiftForWord)
put: (self fetchPointer: i + ClosureFirstCopiedValueIndex
ofObject: theBlockClosure)].
"The initial instructions in the block nil-out remaining temps."
self pop: argumentCount + 1.
self newActiveContext: newContext!
Item was changed:
----- Method: NewspeakInterpreter>>activateNewMethod (in category 'message sending') -----
activateNewMethod
| newContext methodHeader initialIP tempCount nilOop where errorCode |
methodHeader := self methodHeaderOf: newMethod.
newContext := self allocateOrRecycleContext: (methodHeader bitAnd: LargeContextBit).
+ initialIP := ((LiteralStart + (self literalCountOfMethodHeader: methodHeader)) * self wordSize) + 1.
- initialIP := ((LiteralStart + (self literalCountOfMethodHeader: methodHeader)) * BytesPerWord) + 1.
tempCount := (methodHeader >> 19) bitAnd: 16r3F.
"Assume: newContext will be recorded as a root if necessary by the
call to newActiveContext: below, so we can use unchecked stores."
+ where := newContext + self baseHeaderSize.
+ self longAt: where + (SenderIndex << self shiftForWord) put: activeContext.
+ self longAt: where + (InstructionPointerIndex << self shiftForWord) put: (self integerObjectOf: initialIP).
+ self longAt: where + (StackPointerIndex << self shiftForWord) put: (self integerObjectOf: tempCount).
+ self longAt: where + (MethodIndex << self shiftForWord) put: newMethod.
+ self longAt: where + (ClosureIndex << self shiftForWord) put: nilObj.
- where := newContext + BaseHeaderSize.
- self longAt: where + (SenderIndex << ShiftForWord) put: activeContext.
- self longAt: where + (InstructionPointerIndex << ShiftForWord) put: (self integerObjectOf: initialIP).
- self longAt: where + (StackPointerIndex << ShiftForWord) put: (self integerObjectOf: tempCount).
- self longAt: where + (MethodIndex << ShiftForWord) put: newMethod.
- self longAt: where + (ClosureIndex << ShiftForWord) put: nilObj.
"Copy the receiver and arguments..."
0 to: argumentCount do:
+ [:i | self longAt: where + ((ReceiverIndex+i) << self shiftForWord) put: (self stackValue: argumentCount-i)].
- [:i | self longAt: where + ((ReceiverIndex+i) << ShiftForWord) put: (self stackValue: argumentCount-i)].
"clear remaining temps to nil in case it has been recycled"
nilOop := nilObj.
argumentCount+1+ReceiverIndex to: tempCount+ReceiverIndex do:
+ [:i | self longAt: where + (i << self shiftForWord) put: nilOop].
- [:i | self longAt: where + (i << ShiftForWord) put: nilOop].
"Pass primitive error code to last temp if method receives it (indicated
by an initial long store temp bytecode). Protect against obsolete values
in primFailCode by checking that newMethod actually has a primitive?"
primFailCode > 0 ifTrue:
[((self primitiveIndexOfMethodHeader: methodHeader) > 0
and: [(self fetchByte: initialIP - 1 ofObject: newMethod) = 129 "long store temp"]) ifTrue:
[errorCode := self fetchPointer: primFailCode - 1 ofObject: (self splObj: PrimErrTableIndex).
+ self longAt: where + ((tempCount+ReceiverIndex) << self shiftForWord)
- self longAt: where + ((tempCount+ReceiverIndex) << ShiftForWord)
put: errorCode "nil if primFailCode == 1, or primFailCode"].
primFailCode := 0].
self pop: argumentCount + 1.
reclaimableContextCount := reclaimableContextCount + 1.
self newActiveContext: newContext.!
Item was changed:
----- Method: NewspeakInterpreter>>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 *'>
((self isNonIntegerObject: arrayOop)
and: [self isWordsOrBytes: arrayOop]) ifTrue:
+ [^self cCoerceSimple: (self pointerForOop: arrayOop + self baseHeaderSize) to: #'void *'].
- [^self cCoerceSimple: (self pointerForOop: arrayOop + BaseHeaderSize) to: #'void *'].
self primitiveFail!
Item was changed:
----- Method: NewspeakInterpreter>>assertClassOf:is: (in category 'utilities') -----
assertClassOf: oop is: classOop
"Succeed if the given (non-integer) object is an instance of the given class. Fail if the object is an integer."
<inline: true>
- <asmLabel: false>
self success: (self isClassOfNonImm: oop equalTo: classOop)!
Item was changed:
----- Method: NewspeakInterpreter>>byteSwapByteObjectsFrom:to: (in category 'image save/restore') -----
byteSwapByteObjectsFrom: startOop to: stopAddr
"Byte-swap the words of all bytes objects in a range of the
image, including Strings, ByteArrays, and CompiledMethods.
This returns these objects to their original byte ordering
after blindly byte-swapping the entire image. For compiled
methods, byte-swap only their bytecodes part."
| oop fmt wordAddr methodHeader |
oop := startOop.
[self oop: oop isLessThan: stopAddr]
whileTrue: [(self isFreeObject: oop)
ifFalse: [fmt := self formatOf: oop.
fmt >= 8
ifTrue: ["oop contains bytes"
+ wordAddr := oop + self baseHeaderSize.
- wordAddr := oop + BaseHeaderSize.
fmt >= 12
ifTrue: ["compiled method; start after methodHeader and literals"
+ methodHeader := self longAt: oop + self baseHeaderSize.
+ wordAddr := wordAddr + self wordSize + ((methodHeader >> 10 bitAnd: 255) * self wordSize)].
- methodHeader := self longAt: oop + BaseHeaderSize.
- wordAddr := wordAddr + BytesPerWord + ((methodHeader >> 10 bitAnd: 255) * BytesPerWord)].
self reverseBytesFrom: wordAddr to: oop + (self sizeBitsOf: oop)].
+ (fmt = 6 and: [self wordSize = 8])
- (fmt = 6 and: [BytesPerWord = 8])
ifTrue: ["Object contains 32-bit half-words packed into 64-bit machine words."
+ wordAddr := oop + self baseHeaderSize.
- wordAddr := oop + BaseHeaderSize.
self reverseWordsFrom: wordAddr to: oop + (self sizeBitsOf: oop)]].
oop := self objectAfter: oop]!
Item was changed:
----- Method: NewspeakInterpreter>>closureNumArgs:instructionPointer:numCopiedValues: (in category 'control primitives') -----
closureNumArgs: numArgs instructionPointer: initialIP numCopiedValues: numCopied
| newClosure |
<inline: true>
newClosure := self
instantiateSmallClass: (self splObj: ClassBlockClosure)
+ sizeInBytes: (self wordSize * (ClosureFirstCopiedValueIndex + numCopied)) + self baseHeaderSize.
- sizeInBytes: (BytesPerWord * (ClosureFirstCopiedValueIndex + numCopied)) + BaseHeaderSize.
"Assume: have just allocated a new closure; it must be young. Thus, can use unchecked stores."
self storePointerUnchecked: ClosureStartPCIndex ofObject: newClosure withValue: (self integerObjectOf: initialIP).
self storePointerUnchecked: ClosureNumArgsIndex ofObject: newClosure withValue: (self integerObjectOf: numArgs).
"It is up to the caller to store the outer context and copiedValues."
^newClosure!
Item was changed:
----- Method: NewspeakInterpreter>>createActualMessageTo: (in category 'message sending') -----
createActualMessageTo: aClass
"Bundle up the selector, arguments and lookupClass into a Message object.
In the process it pops the arguments off the stack, and pushes the message object.
This can then be presented as the argument of e.g. #doesNotUnderstand:."
"remap lookupClass in case GC happens during allocation"
| argumentArray message lookupClass |
<inline: false> "This is a useful break-point"
self pushRemappableOop: aClass.
argumentArray := self instantiateClass: (self splObj: ClassArray) indexableSize: argumentCount.
"remap argumentArray in case GC happens during allocation"
self pushRemappableOop: argumentArray.
message := self instantiateClass: (self splObj: ClassMessage) indexableSize: 0.
argumentArray := self popRemappableOop.
lookupClass := self popRemappableOop.
self beRootIfOld: argumentArray.
+ self transfer: argumentCount from: stackPointer - (argumentCount - 1 * self wordSize) to: argumentArray + self baseHeaderSize.
- self transfer: argumentCount from: stackPointer - (argumentCount - 1 * BytesPerWord) to: argumentArray + BaseHeaderSize.
self pop: argumentCount thenPush: message.
argumentCount := 1.
self storePointerUnchecked: MessageSelectorIndex ofObject: message withValue: messageSelector.
self storePointerUnchecked: MessageArgumentsIndex ofObject: message withValue: argumentArray.
self storePointerUnchecked: MessageLookupClassIndex ofObject: message withValue: lookupClass!
Item was changed:
----- Method: NewspeakInterpreter>>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"
((self isNonIntegerObject: oop)
and: [(self fetchClassOfNonImm: oop) = (self splObj: ClassFloat)]) ifTrue:
[self cCode: '' inSmalltalk: [result := Float new: 2].
+ self fetchFloatAt: oop + self baseHeaderSize into: result.
- self fetchFloatAt: oop + BaseHeaderSize into: result.
^result].
^nil!
Item was added:
+ ----- Method: NewspeakInterpreter>>declareCVarsIn: (in category 'as yet unclassified') -----
+ declareCVarsIn: aCCodeGenerator
+
+ aCCodeGenerator
+ addHeaderFile:'<stddef.h> /* for e.g. alloca */';
+ addHeaderFile:'<setjmp.h>';
+ addHeaderFile:'"vmCallback.h"';
+ addHeaderFile:'"dispdbg.h"'.
+ aCCodeGenerator
+ var: #interpreterProxy
+ type: #'struct VirtualMachine*'.
+ aCCodeGenerator
+ declareVar: #sendTrace type: 'volatile int';
+ declareVar: #byteCount type: 'unsigned long'.
+ aCCodeGenerator
+ var: #primitiveTable
+ declareC: 'void *primitiveTable[', (MaxPrimitiveIndex +2) printString, '] = ', self primitiveTableString.
+ aCCodeGenerator
+ var: #primitiveFunctionPointer
+ declareC: 'void (*primitiveFunctionPointer)()'.
+ aCCodeGenerator
+ var: #methodCache
+ declareC: 'long methodCache[', (MethodCacheSize + 1) printString, ']'.
+ aCCodeGenerator
+ var: #atCache
+ declareC: 'sqInt atCache[', (AtCacheTotalSize + 1) printString, ']'.
+ aCCodeGenerator var: #localIP type: #'char*'.
+ aCCodeGenerator var: #localSP type: #'char*'.
+ aCCodeGenerator var: #showSurfaceFn type: #'void*'.
+ "Newspeak as of mid 2011 derives SystemScope systemName from the interpreterVersion (via system attribute 1004)
+ by copying up to but not including the last space, provided the string ends with a digit. So spaces must be eliminated
+ from the Monitcello version string, and we can't surround it with square brackets.."
+ (aCCodeGenerator shortMonticelloDescriptionForClass: self) last isDigit ifFalse:
+ [self error: 'Newspeak expects interpreterVersion ends with a digit'].
+ aCCodeGenerator
+ var: #interpreterVersion
+ declareC: 'const char *interpreterVersion = "Newspeak Virtual Machine ',
+ ((aCCodeGenerator shortMonticelloDescriptionForClass: self) copyReplaceAll: ' ' with: '_'),
+ '"'.
+ aCCodeGenerator
+ var: #externalPrimitiveTable
+ declareC: 'void *externalPrimitiveTable[', (MaxExternalPrimitiveTableSize + 1) printString, ']'.
+
+ aCCodeGenerator
+ var: #imageFormatVersionNumber
+ declareC: 'sqInt imageFormatVersionNumber = ',
+ (self wordSize == 4
+ ifTrue: ['6502']
+ ifFalse: ['68000']).
+ aCCodeGenerator
+ var: #breakSelector type: #'char *';
+ var: #breakSelectorLength
+ declareC: 'sqInt breakSelectorLength = -1';
+ var: #primTraceLogIndex type: #'unsigned char';
+ var: #primTraceLog declareC: 'sqInt primTraceLog[256]';
+ var: #sendTraceLogIndex type: #'unsigned char';
+ var: #sendTraceLog declareC: 'sqInt sendTraceLog[256]'
+ !
Item was changed:
----- Method: NewspeakInterpreter>>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 := self splObj: TheDisplay.
aForm = displayObj ifFalse: [^ nil].
self success: ((self isPointers: displayObj) and: [(self lengthOf: displayObj) >= 4]).
self successful ifTrue: [
dispBits := self fetchPointer: 0 ofObject: displayObj.
w := self fetchInteger: 1 ofObject: displayObj.
h := self fetchInteger: 2 ofObject: displayObj.
d := self fetchInteger: 3 ofObject: displayObj.
].
l < 0 ifTrue:[left := 0] ifFalse: [left := l].
r > w ifTrue: [right := w] ifFalse: [right := r].
t < 0 ifTrue: [top := 0] ifFalse: [top := t].
b > h ifTrue: [bottom := h] ifFalse: [bottom := b].
((left <= right) and: [top <= bottom]) ifFalse: [^nil].
self successful ifTrue: [
(self isIntegerObject: dispBits) ifTrue: [
surfaceHandle := self integerValueOf: dispBits.
showSurfaceFn = 0 ifTrue: [
showSurfaceFn := self ioLoadFunction: 'ioShowSurface' From: 'SurfacePlugin'.
showSurfaceFn = 0 ifTrue: [^self success: false]].
self cCode:'((sqInt (*)(sqInt, sqInt, sqInt, sqInt, sqInt))showSurfaceFn)(surfaceHandle, left, top, right-left, bottom-top)'.
] ifFalse: [
+ dispBitsIndex := dispBits + self baseHeaderSize. "index in memory byte array"
- dispBitsIndex := dispBits + 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: NewspeakInterpreter>>fetchContextRegisters: (in category 'contexts') -----
fetchContextRegisters: activeCntx
"Note: internalFetchContextRegisters: should track changes to this method."
| tmp |
<inline: true>
tmp := self fetchPointer: MethodIndex ofObject: activeCntx.
(self isIntegerObject: tmp)
ifTrue: ["if the MethodIndex field is an integer, activeCntx is a block context"
tmp := self fetchPointer: HomeIndex ofObject: activeCntx.
tmp < youngStart ifTrue: [self beRootIfOld: tmp]]
ifFalse: ["otherwise, it is a method context and is its own home context "
tmp := activeCntx].
theHomeContext := tmp.
receiver := self fetchPointer: ReceiverIndex ofObject: tmp.
method := self fetchPointer: MethodIndex ofObject: tmp.
"the instruction pointer is a pointer variable equal to
method oop + ip + BaseHeaderSize
-1 for 0-based addressing of fetchByte
-1 because it gets incremented BEFORE fetching currentByte "
tmp := self quickFetchInteger: InstructionPointerIndex ofObject: activeCntx.
+ instructionPointer := method + tmp + self baseHeaderSize - 2.
- instructionPointer := method + tmp + BaseHeaderSize - 2.
"the stack pointer is a pointer variable also..."
tmp := self quickFetchInteger: StackPointerIndex ofObject: activeCntx.
+ stackPointer := activeCntx + self baseHeaderSize + (TempFrameStart + tmp - 1 * self wordSize)!
- stackPointer := activeCntx + BaseHeaderSize + (TempFrameStart + tmp - 1 * BytesPerWord)!
Item was changed:
----- Method: NewspeakInterpreter>>fetchIntegerOrTruncFloat:ofObject: (in category 'utilities') -----
fetchIntegerOrTruncFloat: fieldIndex ofObject: objectPointer
"Return the integer value of the given field of the given object. If the field contains a Float, truncate it and return its integral part. Fail if the given field does not contain a small integer or Float, or if the truncated Float is out of the range of small integers."
"Note: May be called by translated primitive code."
| intOrFloat floatVal frac trunc |
<inline: false>
<var: #floatVal type: 'double '>
<var: #frac type: 'double '>
<var: #trunc type: 'double '>
intOrFloat := self fetchPointer: fieldIndex ofObject: objectPointer.
(self isIntegerObject: intOrFloat) ifTrue: [^ self integerValueOf: intOrFloat].
self assertClassOf: intOrFloat is: (self splObj: ClassFloat).
self successful ifTrue: [
self cCode: '' inSmalltalk: [floatVal := Float new: 2].
+ self fetchFloatAt: intOrFloat + self baseHeaderSize into: floatVal.
- self fetchFloatAt: intOrFloat + BaseHeaderSize into: floatVal.
self cCode: 'frac = modf(floatVal, &trunc)'.
"the following range check is for C ints, with range -2^31..2^31-1"
self flag: #Dan. "The ranges are INCORRECT if SmallIntegers are wider than 31 bits."
self cCode: 'success((-2147483648.0 <= trunc) && (trunc <= 2147483647.0))'.].
self successful
ifTrue: [^ self cCode: '((sqInt) trunc)' inSmalltalk: [floatVal truncated]]
ifFalse: [^ 0].
!
Item was changed:
----- Method: NewspeakInterpreter>>floatObjectOf: (in category 'object format') -----
floatObjectOf: aFloat
| newFloatObj |
<var: #aFloat type: #double>
<inline: false> "because storeFloatAt:from: insists that its last arg is a variable"
self flag: #Dan. "None of the float stuff has been converted for 64 bits"
+ newFloatObj := self instantiateSmallClass: (self splObj: ClassFloat) sizeInBytes: 8+self baseHeaderSize.
+ self storeFloatAt: newFloatObj + self baseHeaderSize from: aFloat.
- newFloatObj := self instantiateSmallClass: (self splObj: ClassFloat) sizeInBytes: 8+BaseHeaderSize.
- self storeFloatAt: newFloatObj + BaseHeaderSize from: aFloat.
^newFloatObj!
Item was changed:
----- Method: NewspeakInterpreter>>floatValueOf: (in category 'utilities') -----
floatValueOf: oop
"Answer the C double precision floating point value of the argument,
or fail if it is not a Float, and answer 0.
Note: May be called by translated primitive code."
| isFloat result |
<returnTypeC: #double>
<var: #result type: #double>
isFloat := self isInstanceOfClassFloat: oop.
isFloat ifTrue:
[self cCode: '' inSmalltalk: [result := Float new: 2].
+ self fetchFloatAt: oop + self baseHeaderSize into: result.
- self fetchFloatAt: oop + BaseHeaderSize into: result.
^result].
self primitiveFail.
^0.0!
Item was changed:
----- Method: NewspeakInterpreter>>highBit: (in category 'process primitive support') -----
highBit: anUnsignedValue
"This is a C implementation needed by ioSetMaxExtSemTableSize."
| shifted bitNo |
<api>
<var: #anUnsignedValue type: #usqInt>
<var: #shifted type: #usqInt>
shifted := anUnsignedValue.
bitNo := 0.
+ self cppIf: self wordSize > 4
- self cppIf: 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: NewspeakInterpreter>>imageFormatCompatibilityVersion (in category 'image save/restore') -----
imageFormatCompatibilityVersion
"This VM is backward-compatible with the immediately preceeding non-closure version."
+ self wordSize == 4
- BytesPerWord == 4
ifTrue: [^6502]
ifFalse: [^68000]!
Item was changed:
----- Method: NewspeakInterpreter>>imageFormatForwardCompatibilityVersion (in category 'image save/restore') -----
imageFormatForwardCompatibilityVersion
"This VM is forwards-compatible with the immediately following closure version, and
will write the new version number in snapshots if the closure creation bytecode is used."
+ self wordSize == 4
- BytesPerWord == 4
ifTrue: [^6504]
ifFalse: [^68002]!
Item was changed:
----- Method: NewspeakInterpreter>>internalActivateNewMethod (in category 'message sending') -----
internalActivateNewMethod
| methodHeader initialIP newContext tempCount argCount2 needsLarge where |
<inline: true>
methodHeader := self methodHeaderOf: newMethod.
needsLarge := methodHeader bitAnd: LargeContextBit.
(needsLarge = 0 and: [freeContexts ~= NilContext])
ifTrue: [newContext := freeContexts.
freeContexts := self fetchPointer: 0 ofObject: newContext]
ifFalse: ["Slower call for large contexts or empty free list"
self externalizeIPandSP.
newContext := self allocateOrRecycleContext: needsLarge.
self internalizeIPandSP].
+ initialIP := ((LiteralStart + (self literalCountOfMethodHeader: methodHeader)) * self wordSize) + 1.
- initialIP := ((LiteralStart + (self literalCountOfMethodHeader: methodHeader)) * BytesPerWord) + 1.
tempCount := (methodHeader >> 19) bitAnd: 16r3F.
"Assume: newContext will be recorded as a root if necessary by the
call to newActiveContext: below, so we can use unchecked stores."
+ where := newContext + self baseHeaderSize.
+ self longAt: where + (SenderIndex << self shiftForWord) put: activeContext.
+ self longAt: where + (InstructionPointerIndex << self shiftForWord) put: (self integerObjectOf: initialIP).
+ self longAt: where + (StackPointerIndex << self shiftForWord) put: (self integerObjectOf: tempCount).
+ self longAt: where + (MethodIndex << self shiftForWord) put: newMethod.
+ self longAt: where + (ClosureIndex << self shiftForWord) put: nilObj.
- where := newContext + BaseHeaderSize.
- self longAt: where + (SenderIndex << ShiftForWord) put: activeContext.
- self longAt: where + (InstructionPointerIndex << ShiftForWord) put: (self integerObjectOf: initialIP).
- self longAt: where + (StackPointerIndex << ShiftForWord) put: (self integerObjectOf: tempCount).
- self longAt: where + (MethodIndex << ShiftForWord) put: newMethod.
- self longAt: where + (ClosureIndex << ShiftForWord) put: nilObj.
"Copy the receiver and arguments..."
argCount2 := argumentCount.
0 to: argCount2 do:
+ [:i | self longAt: where + ((ReceiverIndex+i) << self shiftForWord) put: (self internalStackValue: argCount2-i)].
- [:i | self longAt: where + ((ReceiverIndex+i) << ShiftForWord) put: (self internalStackValue: argCount2-i)].
"clear remaining temps to nil in case it has been recycled"
needsLarge := nilObj. "needsLarge here used just as faster (register?) temp"
argCount2+1+ReceiverIndex to: tempCount+ReceiverIndex do:
+ [:i | self longAt: where + (i << self shiftForWord) put: needsLarge].
- [:i | self longAt: where + (i << ShiftForWord) put: needsLarge].
"Pass primitive error code to last temp if method receives it (indicated
by an initial long store temp bytecode). Protect against obsolete values
in primFailCode by checking that newMethod actually has a primitive?"
primFailCode > 0 ifTrue:
[((self primitiveIndexOfMethodHeader: methodHeader) > 0
and: [(self fetchByte: initialIP - 1 ofObject: newMethod) = 129 "long store temp"]) ifTrue:
[needsLarge := self fetchPointer: primFailCode - 1 ofObject: (self splObj: PrimErrTableIndex).
+ self longAt: where + ((tempCount+ReceiverIndex) << self shiftForWord)
- self longAt: where + ((tempCount+ReceiverIndex) << ShiftForWord)
put: needsLarge "nil if primFailCode == 1, or primFailCode"].
primFailCode := 0].
self internalPop: argCount2 + 1.
reclaimableContextCount := reclaimableContextCount + 1.
self internalNewActiveContext: newContext.
!
Item was changed:
----- Method: NewspeakInterpreter>>internalFetchContextRegisters: (in category 'contexts') -----
internalFetchContextRegisters: activeCntx
"Inlined into return bytecodes. The only difference between this method and fetchContextRegisters: is that this method sets the local IP and SP."
| tmp |
<inline: true>
tmp := self fetchPointer: MethodIndex ofObject: activeCntx.
(self isIntegerObject: tmp) ifTrue: [
"if the MethodIndex field is an integer, activeCntx is a block context"
tmp := self fetchPointer: HomeIndex ofObject: activeCntx.
(tmp < youngStart) ifTrue: [ self beRootIfOld: tmp ].
] ifFalse: [
"otherwise, it is a method context and is its own home context"
tmp := activeCntx.
].
localHomeContext := tmp.
receiver := self fetchPointer: ReceiverIndex ofObject: tmp.
method := self fetchPointer: MethodIndex ofObject: tmp.
"the instruction pointer is a pointer variable equal to
method oop + ip + BaseHeaderSize
-1 for 0-based addressing of fetchByte
-1 because it gets incremented BEFORE fetching currentByte"
tmp := self quickFetchInteger: InstructionPointerIndex ofObject: activeCntx.
+ localIP := self pointerForOop: method + tmp + self baseHeaderSize - 2.
- localIP := self pointerForOop: method + tmp + BaseHeaderSize - 2.
"the stack pointer is a pointer variable also..."
tmp := self quickFetchInteger: StackPointerIndex ofObject: activeCntx.
+ localSP := self pointerForOop: activeCntx + self baseHeaderSize + ((TempFrameStart + tmp - 1) * self wordSize)!
- localSP := self pointerForOop: activeCntx + BaseHeaderSize + ((TempFrameStart + tmp - 1) * BytesPerWord)!
Item was changed:
----- Method: NewspeakInterpreter>>internalPop: (in category 'internal interpreter access') -----
internalPop: nItems
+ localSP := localSP - (nItems * self wordSize).!
- localSP := localSP - (nItems * BytesPerWord).!
Item was changed:
----- Method: NewspeakInterpreter>>internalPop:thenPush: (in category 'internal interpreter access') -----
internalPop: nItems thenPush: oop
+ self longAtPointer: (localSP := localSP - ((nItems - 1) * self wordSize)) put: oop.
- self longAtPointer: (localSP := localSP - ((nItems - 1) * BytesPerWord)) put: oop.
!
Item was changed:
----- Method: NewspeakInterpreter>>internalPush: (in category 'internal interpreter access') -----
internalPush: object
+ self longAtPointer: (localSP := localSP + self wordSize) put: object.!
- self longAtPointer: (localSP := localSP + BytesPerWord) put: object.!
Item was changed:
----- Method: NewspeakInterpreter>>internalStackValue: (in category 'internal interpreter access') -----
internalStackValue: offset
+ ^ self longAtPointer: localSP - (offset * self wordSize)!
- ^ self longAtPointer: localSP - (offset * BytesPerWord)!
Item was changed:
----- Method: NewspeakInterpreter>>internalStoreContextRegisters: (in category 'contexts') -----
internalStoreContextRegisters: activeCntx
"The only difference between this method and fetchContextRegisters: is that this method stores from the local IP and SP."
"InstructionPointer is a pointer variable equal to
method oop + ip + BaseHeaderSize
-1 for 0-based addressing of fetchByte
-1 because it gets incremented BEFORE fetching currentByte"
<inline: true>
self storePointerUnchecked: InstructionPointerIndex ofObject: activeCntx
withValue: (self integerObjectOf:
+ ((self oopForPointer: localIP) + 2 - (method + self baseHeaderSize))).
- ((self oopForPointer: localIP) + 2 - (method + BaseHeaderSize))).
self storePointerUnchecked: StackPointerIndex ofObject: activeCntx
withValue: (self integerObjectOf:
+ ((((self oopForPointer: localSP) - (activeCntx + self baseHeaderSize)) >> self shiftForWord) - TempFrameStart + 1)).
- ((((self oopForPointer: localSP) - (activeCntx + BaseHeaderSize)) >> ShiftForWord) - TempFrameStart + 1)).
!
Item was changed:
----- Method: NewspeakInterpreter>>justActivateNewMethod (in category 'callback support') -----
justActivateNewMethod
"Activate the new method but *do not* copy receiver or arguments from activeContext."
| methodHeader initialIP newContext tempCount needsLarge where |
<inline: true>
methodHeader := self methodHeaderOf: newMethod.
needsLarge := methodHeader bitAnd: LargeContextBit.
(needsLarge = 0 and: [freeContexts ~= NilContext])
ifTrue: [newContext := freeContexts.
freeContexts := self fetchPointer: 0 ofObject: newContext]
ifFalse: ["Slower call for large contexts or empty free list"
newContext := self allocateOrRecycleContext: needsLarge].
+ initialIP := ((LiteralStart + (self literalCountOfMethodHeader: methodHeader)) * self wordSize) + 1.
- initialIP := ((LiteralStart + (self literalCountOfMethodHeader: methodHeader)) * BytesPerWord) + 1.
tempCount := (methodHeader >> 19) bitAnd: 16r3F.
"Assume: newContext will be recorded as a root if necessary by the
call to newActiveContext: below, so we can use unchecked stores."
+ where := newContext + self baseHeaderSize.
+ self longAt: where + (SenderIndex << self shiftForWord) put: activeContext.
+ self longAt: where + (InstructionPointerIndex << self shiftForWord) put: (self integerObjectOf: initialIP).
+ self longAt: where + (StackPointerIndex << self shiftForWord) put: (self integerObjectOf: tempCount).
+ self longAt: where + (MethodIndex << self shiftForWord) put: newMethod.
- where := newContext + BaseHeaderSize.
- self longAt: where + (SenderIndex << ShiftForWord) put: activeContext.
- self longAt: where + (InstructionPointerIndex << ShiftForWord) put: (self integerObjectOf: initialIP).
- self longAt: where + (StackPointerIndex << ShiftForWord) put: (self integerObjectOf: tempCount).
- self longAt: where + (MethodIndex << ShiftForWord) put: newMethod.
"Set the receiver..."
+ self longAt: where + (ReceiverIndex << self shiftForWord) put: receiver.
- self longAt: where + (ReceiverIndex << ShiftForWord) put: receiver.
"clear all args and temps to nil in case it has been recycled"
needsLarge := nilObj. "needsLarge here used just as faster (register?) temp"
ReceiverIndex + 1 to: tempCount + ReceiverIndex do:
+ [:i | self longAt: where + (i << self shiftForWord) put: needsLarge].
- [:i | self longAt: where + (i << ShiftForWord) put: needsLarge].
reclaimableContextCount := reclaimableContextCount + 1.
activeContext := newContext.
(self oop: newContext isLessThan: youngStart) ifTrue:
[self beRootIfOld: newContext].
self fetchContextRegisters: activeContext!
Item was changed:
----- Method: NewspeakInterpreter>>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."
<inline: true>
- <asmLabel: false>
<returnTypeC: #double>
(self isIntegerObject: floatOrInt) ifTrue:
[^(self integerValueOf: floatOrInt) asFloat].
^self floatValueOf: floatOrInt!
Item was changed:
----- Method: NewspeakInterpreter>>lookupInMethodCacheSel:class: (in category 'method lookup cache') -----
lookupInMethodCacheSel: selector class: class
"This method implements a simple method lookup cache. If an entry for the given selector and class is found in the cache, set the values of 'newMethod' and 'primitiveFunctionPointer' and return true. Otherwise, return false."
"About the re-probe scheme: The hash is the low bits of the XOR of two large addresses, minus their useless lowest two bits. If a probe doesn't get a hit, the hash is shifted right one bit to compute the next probe, introducing a new randomish bit. The cache is probed CacheProbeMax times before giving up."
"WARNING: Since the hash computation is based on the object addresses of the class and selector, we must rehash or flush when compacting storage. We've chosen to flush, since that also saves the trouble of updating the addresses of the objects in the cache."
| hash probe |
<inline: true>
- <asmLabel: false>
hash := selector bitXor: class. "shift drops two low-order zeros from addresses"
probe := hash bitAnd: MethodCacheMask. "first probe"
(((methodCache at: probe + MethodCacheSelector) = selector) and:
[(methodCache at: probe + MethodCacheClass) = class]) ifTrue:
[newMethod := methodCache at: probe + MethodCacheMethod.
primitiveFunctionPointer := self cCoerceSimple: (methodCache at: probe + MethodCachePrimFunction)
to: #'void (*)()'.
^ true "found entry in cache; done"].
probe := (hash >> 1) bitAnd: MethodCacheMask. "second probe"
(((methodCache at: probe + MethodCacheSelector) = selector) and:
[(methodCache at: probe + MethodCacheClass) = class]) ifTrue:
[newMethod := methodCache at: probe + MethodCacheMethod.
primitiveFunctionPointer := self cCoerceSimple: (methodCache at: probe + MethodCachePrimFunction)
to: #'void (*)()'.
^ true "found entry in cache; done"].
probe := (hash >> 2) bitAnd: MethodCacheMask.
(((methodCache at: probe + MethodCacheSelector) = selector) and:
[(methodCache at: probe + MethodCacheClass) = class]) ifTrue:
[newMethod := methodCache at: probe + MethodCacheMethod.
primitiveFunctionPointer := self cCoerceSimple: (methodCache at: probe + MethodCachePrimFunction)
to: #'void (*)()'.
^ true "found entry in cache; done"].
^ false!
Item was changed:
----- Method: NewspeakInterpreter>>lookupMethodInClass: (in category 'message sending') -----
lookupMethodInClass: class
| currentClass dictionary found rclass |
<inline: false>
currentClass := class.
[currentClass ~= nilObj]
whileTrue:
[dictionary := self fetchPointer: MessageDictionaryIndex ofObject: currentClass.
dictionary = nilObj ifTrue:
["MethodDict pointer is nil (hopefully due a swapped out stub)
-- raise exception #cannotInterpret:."
self pushRemappableOop: currentClass. "may cause GC!!"
self createActualMessageTo: class.
currentClass := self popRemappableOop.
messageSelector := self splObj: SelectorCannotInterpret.
self fastLogSend: messageSelector.
self sendBreakpoint: 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 = (self splObj: SelectorDoesNotUnderstand) ifTrue:
[self error: 'Recursive not understood error encountered'].
"Cound not find a normal message -- raise exception #doesNotUnderstand:"
self pushRemappableOop: class. "may cause GC!!"
self createActualMessageTo: class.
rclass := self popRemappableOop.
messageSelector := self splObj: SelectorDoesNotUnderstand.
RecordSendTrace ifTrue:
[self fastLogSend: messageSelector].
+ self sendBreak: messageSelector + self baseHeaderSize
- self sendBreak: messageSelector + BaseHeaderSize
point: (self lengthOf: messageSelector)
receiver: nil.
^ self lookupMethodInClass: rclass!
Item was changed:
----- Method: NewspeakInterpreter>>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 := self instantiateSmallClass: (self splObj: ClassPoint) sizeInBytes: 3*self wordSize.
- pointResult := self instantiateSmallClass: (self splObj: ClassPoint) sizeInBytes: 3*BytesPerWord.
self storePointerUnchecked: XIndex ofObject: pointResult withValue: (self integerObjectOf: xValue).
self storePointerUnchecked: YIndex ofObject: pointResult withValue: (self integerObjectOf: yValue).
^ pointResult!
Item was changed:
----- Method: NewspeakInterpreter>>pop: (in category 'internal interpreter access') -----
pop: nItems
"Note: May be called by translated primitive code."
+ stackPointer := stackPointer - (nItems*self wordSize).!
- stackPointer := stackPointer - (nItems*BytesPerWord).!
Item was changed:
----- Method: NewspeakInterpreter>>pop:thenPush: (in category 'internal interpreter access') -----
pop: nItems thenPush: oop
| sp |
+ self longAt: (sp := stackPointer - ((nItems - 1) * self wordSize)) put: oop.
- self longAt: (sp := stackPointer - ((nItems - 1) * BytesPerWord)) put: oop.
stackPointer := sp.
!
Item was changed:
----- Method: NewspeakInterpreter>>pop:thenPushBool: (in category 'contexts') -----
pop: nItems thenPushBool: trueOrFalse
"A few places pop a few items off the stack and then push a boolean. Make it convenient"
| sp |
+ self longAt: (sp := stackPointer - ((nItems - 1) * self wordSize))
- self longAt: (sp := stackPointer - ((nItems - 1) * BytesPerWord))
put:(trueOrFalse ifTrue: [trueObj] ifFalse: [falseObj]).
stackPointer := sp!
Item was changed:
----- Method: NewspeakInterpreter>>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"
| sp |
+ self longAt: (sp := stackPointer - ((nItems - 1) * self wordSize)) put:(self integerObjectOf: integerVal).
- self longAt: (sp := stackPointer - ((nItems - 1) * BytesPerWord)) put:(self integerObjectOf: integerVal).
stackPointer := sp.
!
Item was changed:
----- Method: NewspeakInterpreter>>popStack (in category 'internal interpreter access') -----
popStack
| top |
top := self longAt: stackPointer.
+ stackPointer := stackPointer - self wordSize.
- stackPointer := stackPointer - BytesPerWord.
^ top!
Item was changed:
----- Method: NewspeakInterpreter>>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: [(self isIntegerValue: integerValue)
ifTrue: [^ self integerObjectOf: integerValue]].
+ self wordSize = 4
- BytesPerWord = 4
ifTrue: ["Faster instantiateSmallClass: currently only works with integral word size."
newLargeInteger := self instantiateSmallClass: (self splObj: ClassLargePositiveInteger)
+ sizeInBytes: self baseHeaderSize + 4]
- sizeInBytes: BaseHeaderSize + 4]
ifFalse: ["Cant use instantiateSmallClass: due to integral word requirement."
newLargeInteger := self instantiateClass: (self splObj: ClassLargePositiveInteger)
indexableSize: 4].
self storeByte: 3 ofObject: newLargeInteger withValue: ((integerValue >> 24) bitAnd: 16rFF).
self storeByte: 2 ofObject: newLargeInteger withValue: ((integerValue >> 16) bitAnd: 16rFF).
self storeByte: 1 ofObject: newLargeInteger withValue: ((integerValue >> 8) bitAnd: 16rFF).
self storeByte: 0 ofObject: newLargeInteger withValue: (integerValue bitAnd: 16rFF).
^ newLargeInteger!
Item was changed:
----- Method: NewspeakInterpreter>>positive64BitIntegerFor: (in category 'primitive support') -----
positive64BitIntegerFor: integerValue
| newLargeInteger value check |
"Note - integerValue is interpreted as POSITIVE, eg, as the result of
Bitmap>at:, or integer>bitAnd:."
<var: 'integerValue' type: 'sqLong'>
(self sizeof: integerValue) = 4 ifTrue: [^self positive32BitIntegerFor: integerValue].
self cCode: 'check = integerValue >> 32'. "Why not run this in sim?"
check = 0 ifTrue: [^self positive32BitIntegerFor: integerValue].
newLargeInteger :=
+ self instantiateSmallClass: (self splObj: ClassLargePositiveInteger) sizeInBytes: self baseHeaderSize + 8.
- self instantiateSmallClass: (self splObj: ClassLargePositiveInteger) sizeInBytes: BaseHeaderSize + 8.
0 to: 7 do: [:i |
self cCode: 'value = ( integerValue >> (i * 8)) & 255'.
self storeByte: i ofObject: newLargeInteger withValue: value].
^ newLargeInteger!
Item was changed:
----- Method: NewspeakInterpreter>>primitiveBeCursor (in category 'I/O primitives') -----
primitiveBeCursor
"Set the cursor to the given shape. The Mac only supports 16x16 pixel cursors. Cursor offsets are handled by Smalltalk."
| cursorObj maskBitsIndex maskObj bitsObj extentX extentY depth offsetObj offsetX offsetY cursorBitsIndex ourCursor |
argumentCount = 0 ifTrue: [
cursorObj := self stackTop.
maskBitsIndex := nil].
argumentCount = 1 ifTrue: [
cursorObj := self stackValue: 1.
maskObj := self stackTop].
self success: (argumentCount < 2).
self success: ((self isPointers: cursorObj) and: [(self lengthOf: cursorObj) >= 5]).
self successful ifTrue: [
bitsObj := self fetchPointer: 0 ofObject: cursorObj.
extentX := self fetchInteger: 1 ofObject: cursorObj.
extentY := self fetchInteger: 2 ofObject: cursorObj.
depth := self fetchInteger: 3 ofObject: cursorObj.
offsetObj := self fetchPointer: 4 ofObject: cursorObj].
self success: ((self isPointers: offsetObj) and: [(self lengthOf: offsetObj) >= 2]).
self successful ifTrue: [
offsetX := self fetchInteger: 0 ofObject: offsetObj.
offsetY := self fetchInteger: 1 ofObject: offsetObj.
self success: ((extentX = 16) and: [extentY = 16 and: [depth = 1]]).
self success: ((offsetX >= -16) and: [offsetX <= 0]).
self success: ((offsetY >= -16) and: [offsetY <= 0]).
self success: ((self isWords: bitsObj) and: [(self lengthOf: bitsObj) = 16]).
+ cursorBitsIndex := bitsObj + self baseHeaderSize.
- cursorBitsIndex := bitsObj + BaseHeaderSize.
self cCode: '' inSmalltalk:
[ourCursor := Cursor
extent: extentX @ extentY
fromArray: ((1 to: 16) collect: [:i |
+ ((self fetchLong32: i-1 ofObject: bitsObj) >> (self wordSize*8 - 16)) bitAnd: 16rFFFF])
- ((self fetchLong32: i-1 ofObject: bitsObj) >> (BytesPerWord*8 - 16)) bitAnd: 16rFFFF])
offset: offsetX @ offsetY]].
argumentCount = 1 ifTrue: [
self success: ((self isPointers: maskObj) and: [(self lengthOf: maskObj) >= 5]).
self successful ifTrue: [
bitsObj := self fetchPointer: 0 ofObject: maskObj.
extentX := self fetchInteger: 1 ofObject: maskObj.
extentY := self fetchInteger: 2 ofObject: maskObj.
depth := self fetchInteger: 3 ofObject: maskObj].
self successful ifTrue: [
self success: ((extentX = 16) and: [extentY = 16 and: [depth = 1]]).
self success: ((self isWords: bitsObj) and: [(self lengthOf: bitsObj) = 16]).
+ maskBitsIndex := bitsObj + self baseHeaderSize]].
- maskBitsIndex := bitsObj + BaseHeaderSize]].
self successful ifTrue: [
argumentCount = 0
ifTrue: [self cCode: 'ioSetCursor(cursorBitsIndex, offsetX, offsetY)'
inSmalltalk: [ourCursor show]]
ifFalse: [self cCode: 'ioSetCursorWithMask(cursorBitsIndex, maskBitsIndex, offsetX, offsetY)'
inSmalltalk: [ourCursor show]].
self pop: argumentCount].
!
Item was changed:
----- Method: NewspeakInterpreter>>primitiveBlockCopy (in category 'control primitives') -----
primitiveBlockCopy
| context methodContext contextSize newContext initialIP |
context := self stackValue: 1.
(self isIntegerObject: (self fetchPointer: MethodIndex ofObject: context))
ifTrue: ["context is a block; get the context of its enclosing method"
methodContext := self fetchPointer: HomeIndex ofObject: context]
ifFalse: [methodContext := context].
contextSize := self sizeBitsOf: methodContext. "in bytes, including header"
context := nil. "context is no longer needed and is not preserved across allocation"
"remap methodContext in case GC happens during allocation"
self pushRemappableOop: methodContext.
newContext := self instantiateContext: (self splObj: ClassBlockContext) sizeInBytes: contextSize.
methodContext := self popRemappableOop.
+ initialIP := self integerObjectOf: (instructionPointer+1+3) - (method+self baseHeaderSize).
- initialIP := self integerObjectOf: (instructionPointer+1+3) - (method+BaseHeaderSize).
"Was instructionPointer + 3, but now it's greater by 1 due to preIncrement"
"Assume: have just allocated a new context; it must be young.
Thus, can use uncheck stores. See the comment in fetchContextRegisters."
self storePointerUnchecked: InitialIPIndex ofObject: newContext withValue: initialIP.
self storePointerUnchecked: InstructionPointerIndex ofObject: newContext withValue: initialIP.
self storeStackPointerValue: 0 inContext: newContext.
self storePointerUnchecked: BlockArgumentCountIndex ofObject: newContext withValue: (self stackValue: 0).
self storePointerUnchecked: HomeIndex ofObject: newContext withValue: methodContext.
self storePointerUnchecked: SenderIndex ofObject: newContext withValue: nilObj.
self pop: 2 thenPush: newContext.!
Item was changed:
----- Method: NewspeakInterpreter>>primitiveClipboardText (in category 'I/O primitives') -----
primitiveClipboardText
"When called with a single string argument, post the string to
the clipboard. When called with zero arguments, return a
string containing the current clipboard contents."
| s sz |
argumentCount = 1
ifTrue: [s := self stackTop.
(self isBytes: s) ifFalse: [^ self primitiveFail].
self successful
ifTrue: [sz := self stSizeOf: s.
+ self clipboardWrite: sz From: s + self baseHeaderSize At: 0.
- self clipboardWrite: sz From: s + BaseHeaderSize At: 0.
self pop: 1]]
ifFalse: [sz := self clipboardSize.
(self sufficientSpaceToAllocate: sz) ifFalse:[^self primitiveFail].
s := self instantiateClass: (self splObj: ClassByteString) indexableSize: sz.
+ self clipboardRead: sz Into: s + self baseHeaderSize At: 0.
- self clipboardRead: sz Into: s + BaseHeaderSize At: 0.
self pop: 1 thenPush: s]!
Item was changed:
----- Method: NewspeakInterpreter>>primitiveClosureCopyWithCopiedValues (in category 'control primitives') -----
primitiveClosureCopyWithCopiedValues
| newClosure copiedValues numCopiedValues numArgs |
numArgs := self stackIntegerValue: 1.
copiedValues := self stackTop.
(self fetchClassOf: copiedValues) = (self splObj: ClassArray) ifFalse:
[^self primitiveFail].
numCopiedValues := self numSlotsOf: copiedValues.
newClosure := self
closureNumArgs: numArgs
"greater by 1 due to preIncrement of localIP"
+ instructionPointer: instructionPointer + 2 - (method+self baseHeaderSize)
- instructionPointer: instructionPointer + 2 - (method+BaseHeaderSize)
numCopiedValues: numCopiedValues.
"Assume: have just allocated a new closure; it must be young. Thus, can use unchecked stores."
self storePointerUnchecked: ClosureOuterContextIndex ofObject: newClosure withValue: (self stackValue: 2).
numCopiedValues > 0 ifTrue:
["Allocation may have done a GC and copiedValues may have moved."
copiedValues := self stackTop.
0 to: numCopiedValues - 1 do:
[:i|
"Assume: have just allocated a new BlockClosure; it must be young.
Thus, can use unchecked stores."
self storePointerUnchecked: i + ClosureFirstCopiedValueIndex
ofObject: newClosure
withValue: (self fetchPointer: i ofObject: copiedValues)]].
self pop: 3 thenPush: newClosure!
Item was changed:
----- Method: NewspeakInterpreter>>primitiveConstantFill (in category 'sound primitives') -----
primitiveConstantFill
"Fill the receiver, which must be an indexable bytes or words
objects, with the given integer value."
| fillValue rcvr rcvrIsBytes end i |
fillValue := self positive32BitValueOf: self stackTop.
rcvr := self stackValue: 1.
self success: (self isWordsOrBytes: rcvr).
rcvrIsBytes := self isBytes: rcvr.
rcvrIsBytes ifTrue: [self success: (fillValue >= 0 and: [fillValue <= 255])].
self successful
ifTrue: [end := rcvr + (self sizeBitsOf: rcvr).
+ i := rcvr + self baseHeaderSize.
- i := rcvr + BaseHeaderSize.
rcvrIsBytes
ifTrue: [[i < end]
whileTrue: [self byteAt: i put: fillValue.
i := i + 1]]
ifFalse: [[i < end]
whileTrue: [self long32At: i put: fillValue.
i := i + 4]].
self pop: 1]!
Item was changed:
----- Method: NewspeakInterpreter>>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 index methodArg methodHeader spec
moduleName functionName moduleLength functionLength addr |
<var: #addr declareC: 'void (*addr)()'>
argumentArray := self stackTop.
(self isArray: argumentArray) ifFalse:
[^self primitiveFail]. "invalid args"
arraySize := self numSlotsOf: argumentArray.
self success: (self roomToPushNArgs: arraySize).
methodArg := self stackObjectValue: 2.
self successful ifFalse:
[^self primitiveFail]. "invalid args"
(self isCompiledMethod: methodArg) ifFalse:
[^self primitiveFail]. "invalid args"
methodHeader := self methodHeaderOf: methodArg.
(self literalCountOfMethodHeader: methodHeader) > 2 ifFalse:
[^self primitiveFail]. "invalid methodArg state"
self assertClassOf: (spec := self fetchPointer: 1 "first literal" ofObject: methodArg)
is: (self splObj: ClassArray).
(self successful
and: [(self lengthOf: spec) = 4
and: [(self primitiveIndexOfMethodHeader: methodHeader) = 117]]) ifFalse:
[^self primitiveFail]. "invalid methodArg state"
(self argumentCountOfMethodHeader: methodHeader) = arraySize ifFalse:
[^self primitiveFail]. "invalid args (Array args wrong size)"
"The function has not been loaded yet. Fetch module and function name."
moduleName := self fetchPointer: 0 ofObject: spec.
moduleName = nilObj
ifTrue: [moduleLength := 0]
ifFalse: [self success: (self isBytes: moduleName).
moduleLength := self lengthOf: moduleName.
self cCode: '' inSmalltalk:
[ (#('FloatArrayPlugin' 'Matrix2x3Plugin') includes: (self stringOf: moduleName)) "??"
ifTrue: [moduleLength := 0 "Cause all of these to fail"]]].
functionName := self fetchPointer: 1 ofObject: spec.
self success: (self isBytes: functionName).
functionLength := self lengthOf: functionName.
self successful ifFalse: [^self primitiveFail]. "invalid methodArg state"
+ addr := self ioLoadExternalFunction: functionName + self baseHeaderSize
- addr := self ioLoadExternalFunction: functionName + BaseHeaderSize
OfLength: functionLength
+ FromModule: moduleName + self baseHeaderSize
- FromModule: moduleName + BaseHeaderSize
OfLength: moduleLength.
addr = 0 ifTrue:
[^self primitiveFail]. "could not find function"
"Cannot fail this primitive from now on. Can only fail the external primitive."
self pop: 1.
argumentCount := arraySize.
index := 1.
[index <= arraySize] whileTrue:
[self push: (self fetchPointer: index - 1 ofObject: argumentArray).
index := index + 1].
"Run the primitive (sets primFailCode)"
self pushRemappableOop: argumentArray. "prim might alloc/gc in callback"
lkupClass := nilObj.
self callExternalPrimitive: addr.
argumentArray := self popRemappableOop.
self successful ifFalse: "If primitive failed, then restore state for failure code"
[self pop: arraySize thenPush: argumentArray.
argumentCount := 3]!
Item was changed:
----- Method: NewspeakInterpreter>>primitiveExternalCall (in category 'plugin primitives') -----
primitiveExternalCall
"Call an external primitive. The external primitive methods
contain as first literal an array consisting of:
* The module name (String | Symbol)
* The function name (String | Symbol)
* The session ID (SmallInteger) [OBSOLETE]
* The function index (Integer) in the externalPrimitiveTable
For fast failures the primitive index of any method where the
external prim is not found is rewritten in the method cache
with zero. This allows for ultra fast responses as long as the
method stays in the cache.
The fast failure response relies on lkupClass being properly
set. This is done in
#addToMethodCacheSel:class:method:primIndex: to
compensate for execution of methods that are looked up in a
superclass (such as in primitivePerformAt).
With the latest modifications (e.g., actually flushing the
function addresses from the VM), the session ID is obsolete.
But for backward compatibility it is still kept around. Also, a
failed lookup is reported specially. If a method has been
looked up and not been found, the function address is stored
as -1 (e.g., the SmallInteger -1 to distinguish from
16rFFFFFFFF which may be returned from the lookup).
It is absolutely okay to remove the rewrite if we run into any
problems later on. It has an approximate speed difference of
30% per failed primitive call which may be noticable but if,
for any reasons, we run into problems (like with J3) we can
always remove the rewrite.
"
| lit addr moduleName functionName moduleLength functionLength index |
<var: #addr type: 'void *'>
"Fetch the first literal of the method"
self success: (self literalCountOf: newMethod) > 0. "@@: Could this be omitted for speed?!!"
self successful ifFalse: [^ nil].
lit := self literal: 0 ofMethod: newMethod.
"Check if it's an array of length 4"
self success: ((self isArray: lit) and: [(self lengthOf: lit) = 4]).
self successful ifFalse: [^ nil].
"Look at the function index in case it has been loaded before"
index := self fetchPointer: 3 ofObject: lit.
index := self checkedIntegerValueOf: index.
self successful ifFalse: [^ nil].
"Check if we have already looked up the function and failed."
index < 0 ifTrue:
["Function address was not found in this session,
Rewrite the mcache entry with a zero primitive index."
self
rewriteMethodCacheSel: messageSelector
class: lkupClass
primIndex: 0.
^self success: false].
"Try to call the function directly"
(index > 0 and: [index <= MaxExternalPrimitiveTableSize]) ifTrue:
[addr := externalPrimitiveTable at: index - 1.
addr ~= 0 ifTrue:
[self rewriteMethodCacheSel: messageSelector class: lkupClass primIndex: (1000 + index) primFunction: addr.
self callExternalPrimitive: addr.
^nil].
"if we get here, then an index to the external prim was
kept on the ST side although the underlying prim
table was already flushed"
^self primitiveFail].
"Clean up session id and external primitive index"
self storePointerUnchecked: 2 ofObject: lit withValue: ConstZero.
self storePointerUnchecked: 3 ofObject: lit withValue: ConstZero.
"The function has not been loaded yet. Fetch module and function name."
moduleName := self fetchPointer: 0 ofObject: lit.
moduleName = nilObj
ifTrue: [moduleLength := 0]
ifFalse: [self success: (self isBytes: moduleName).
moduleLength := self lengthOf: moduleName].
functionName := self fetchPointer: 1 ofObject: lit.
self success: (self isBytes: functionName).
functionLength := self lengthOf: functionName.
self successful ifFalse: [^ nil].
+ addr := self ioLoadExternalFunction: functionName + self baseHeaderSize
- addr := self ioLoadExternalFunction: functionName + BaseHeaderSize
OfLength: functionLength
+ FromModule: moduleName + self baseHeaderSize
- FromModule: moduleName + BaseHeaderSize
OfLength: moduleLength.
addr = 0
ifTrue: [index := -1]
ifFalse: ["add the function to the external primitive table"
index := self addToExternalPrimitiveTable: addr].
self success: index >= 0.
"Store the index (or -1 if failure) back in the literal"
self storePointerUnchecked: 3 ofObject: lit withValue: (self integerObjectOf: index).
"If the function has been successfully loaded process it"
(self successful and: [addr ~= 0])
ifTrue:
[self rewriteMethodCacheSel: messageSelector class: lkupClass primIndex: (1000 + index) primFunction: addr.
self callExternalPrimitive: addr]
ifFalse: "Otherwise rewrite the primitive index"
[self
rewriteMethodCacheSel: messageSelector
class: lkupClass
primIndex: 0]!
Item was changed:
----- Method: NewspeakInterpreter>>primitiveFailAfterCleanup: (in category 'image segment in/out') -----
primitiveFailAfterCleanup: outPointerArray
"If the storeSegment primitive fails, it must clean up first."
| i lastAddr | "Store nils throughout the outPointer array."
lastAddr := outPointerArray + (self lastPointerOf: outPointerArray).
+ i := outPointerArray + self baseHeaderSize.
- i := outPointerArray + BaseHeaderSize.
[i <= lastAddr] whileTrue:
[self longAt: i put: nilObj.
+ i := i + self wordSize].
- i := i + BytesPerWord].
DoAssertionChecks ifTrue: [self verifyCleanHeaders].
self primitiveFail!
Item was changed:
----- Method: NewspeakInterpreter>>primitiveGetAttribute (in category 'system control primitives') -----
primitiveGetAttribute
"Fetch the system attribute with the given integer ID. The
result is a string, which will be empty if the attribute is not
defined."
| attr sz s |
attr := self stackIntegerValue: 0.
self successful
ifTrue: [sz := self attributeSize: attr].
self successful
ifTrue: [s := self
instantiateClass: (self splObj: ClassByteString)
indexableSize: sz.
self
getAttribute: attr
+ Into: s + self baseHeaderSize
- Into: s + BaseHeaderSize
Length: sz.
self pop: 2 thenPush: s]!
Item was changed:
----- Method: NewspeakInterpreter>>primitiveImageName (in category 'other primitives') -----
primitiveImageName
"When called with a single string argument, record the string as the current image file name. When called with zero arguments, return a string containing the current image file name."
| s sz sCRIfn okToRename |
<var: #sCRIfn type: 'void *'>
argumentCount = 1 ifTrue: [
"If the security plugin can be loaded, use it to check for rename permission.
If not, assume it's ok"
sCRIfn := self ioLoadFunction: 'secCanRenameImage' From: 'SecurityPlugin'.
sCRIfn ~= 0 ifTrue:[okToRename := self cCode:' ((sqInt (*)(void))sCRIfn)()'.
okToRename ifFalse:[^self primitiveFail]].
s := self stackTop.
self assertClassOf: s is: (self splObj: ClassByteString).
self successful ifTrue: [
sz := self stSizeOf: s.
+ self imageNamePut: (s + self baseHeaderSize) Length: sz.
- self imageNamePut: (s + BaseHeaderSize) Length: sz.
self pop: 1. "pop s, leave rcvr on stack"
].
] ifFalse: [
sz := self imageNameSize.
s := self instantiateClass: (self splObj: ClassByteString) indexableSize: sz.
+ self imageNameGet: (s + self baseHeaderSize) Length: sz.
- self imageNameGet: (s + BaseHeaderSize) Length: sz.
self pop: 1. "rcvr"
self push: s.
].
!
Item was changed:
----- Method: NewspeakInterpreter>>primitiveIntegerAt (in category 'sound primitives') -----
primitiveIntegerAt
"Return the 32bit signed integer contents of a words receiver"
| index rcvr sz addr value |
index := self stackIntegerValue: 0.
self successful ifFalse:
[^self primitiveFailFor: PrimErrBadArgument].
rcvr := self stackValue: 1.
((self isIntegerObject: rcvr)
or: [(self isWords: rcvr) not]) ifTrue:
[^self primitiveFailFor: PrimErrInappropriate].
sz := self lengthOf: rcvr. "number of fields"
((index >= 1) and: [index <= sz]) ifFalse:
[^self primitiveFailFor: PrimErrBadIndex].
+ addr := rcvr + self baseHeaderSize - 4 "for zero indexing" + (index * 4).
- addr := rcvr + BaseHeaderSize - 4 "for zero indexing" + (index * 4).
value := self intAt: addr.
self pop: 2. "pop rcvr, index"
"push element value"
(self isIntegerValue: value)
ifTrue: [self pushInteger: value]
ifFalse: [self push: (self signed32BitIntegerFor: value)]!
Item was changed:
----- Method: NewspeakInterpreter>>primitiveIntegerAtPut (in category 'sound primitives') -----
primitiveIntegerAtPut
"Return the 32bit signed integer contents of a words receiver"
| index rcvr sz addr value valueOop |
valueOop := self stackValue: 0.
index := self stackIntegerValue: 1.
(self isIntegerObject: valueOop)
ifTrue:[value := self integerValueOf: valueOop]
ifFalse:[value := self signed32BitValueOf: valueOop].
self successful ifFalse:
[^self primitiveFailFor: PrimErrBadArgument].
rcvr := self stackValue: 2.
((self isIntegerObject: rcvr)
or: [(self isWords: rcvr) not]) ifTrue:
[^self primitiveFailFor: PrimErrInappropriate].
sz := self lengthOf: rcvr. "number of fields"
(index >= 1 and: [index <= sz]) ifFalse:
[^self primitiveFailFor: PrimErrBadIndex].
(self isOopImmutable: rcvr) ifTrue:
[^self primitiveFailFor: PrimErrNoModification].
+ addr := rcvr + self baseHeaderSize - 4 "for zero indexing" + (index * 4).
- addr := rcvr + BaseHeaderSize - 4 "for zero indexing" + (index * 4).
value := self intAt: addr put: value.
self pop: 3 thenPush: valueOop "pop all; return value"
!
Item was changed:
----- Method: NewspeakInterpreter>>primitiveInvokeObjectAsMethod (in category 'control primitives') -----
primitiveInvokeObjectAsMethod
"Primitive. 'Invoke' an object like a function, sending the special message
run: originalSelector with: arguments in: aReceiver.
"
| runSelector runReceiver runArgs newReceiver lookupClass |
runArgs := self instantiateClass: (self splObj: ClassArray) indexableSize: argumentCount.
self beRootIfOld: runArgs. "do we really need this?"
+ self transfer: argumentCount from: stackPointer - ((argumentCount - 1) * self wordSize) to: runArgs + self baseHeaderSize.
- self transfer: argumentCount from: stackPointer - ((argumentCount - 1) * BytesPerWord) to: runArgs + BaseHeaderSize.
runSelector := messageSelector.
runReceiver := self stackValue: argumentCount.
self pop: argumentCount+1.
"stack is clean here"
newReceiver := newMethod.
messageSelector := self splObj: SelectorRunWithIn.
argumentCount := 3.
self push: newReceiver.
self push: runSelector.
self push: runArgs.
self push: runReceiver.
lookupClass := self fetchClassOf: newReceiver.
self findNewMethodInClass: lookupClass.
self executeNewMethod. "Recursive xeq affects successFlag"
self initPrimCall.
!
Item was changed:
----- Method: NewspeakInterpreter>>primitiveLoadImageSegment (in category 'image segment in/out') -----
primitiveLoadImageSegment
"This primitive is called from Squeak as...
<imageSegment> loadSegmentFrom: aWordArray outPointers: anArray."
"This primitive will load a binary image segment created by primitiveStoreImageSegment. It expects the outPointer array to be of the proper size, and the wordArray to be well formed. It will return as its value the original array of roots, and the erstwhile segmentWordArray will have been truncated to a size of zero. If this primitive should fail, the segmentWordArray will, sadly, have been reduced to an unrecognizable and unusable jumble. But what more could you have done with it anyway?"
| outPointerArray segmentWordArray endSeg segOop fieldPtr fieldOop doingClass lastPtr extraSize mapOop lastOut outPtr hdrTypeBits header data |
DoAssertionChecks ifTrue: [self verifyCleanHeaders].
outPointerArray := self stackTop.
lastOut := outPointerArray + (self lastPointerOf: outPointerArray).
segmentWordArray := self stackValue: 1.
+ endSeg := segmentWordArray + (self sizeBitsOf: segmentWordArray) - self baseHeaderSize.
- endSeg := segmentWordArray + (self sizeBitsOf: segmentWordArray) - BaseHeaderSize.
"Essential type checks"
((self formatOf: outPointerArray) = 2 "Must be indexable pointers"
and: [(self formatOf: segmentWordArray) = 6]) "Must be indexable words"
ifFalse: [^ self primitiveFail].
"Version check. Byte order of the WordArray now"
+ data := self longAt: segmentWordArray + self baseHeaderSize.
- data := self longAt: segmentWordArray + BaseHeaderSize.
(self readableFormat: (data bitAnd: 16rFFFF "low 2 bytes")) ifFalse: [
"Not readable -- try again with reversed bytes..."
+ self reverseBytesFrom: segmentWordArray + self baseHeaderSize to: endSeg + self wordSize.
+ data := self longAt: segmentWordArray + self baseHeaderSize.
- self reverseBytesFrom: segmentWordArray + BaseHeaderSize to: endSeg + BytesPerWord.
- data := self longAt: segmentWordArray + BaseHeaderSize.
(self readableFormat: (data bitAnd: 16rFFFF "low 2 bytes")) ifFalse: [
"Still NG -- put things back and fail"
+ self reverseBytesFrom: segmentWordArray + self baseHeaderSize to: endSeg + self wordSize.
- self reverseBytesFrom: segmentWordArray + BaseHeaderSize to: endSeg + BytesPerWord.
DoAssertionChecks ifTrue: [self verifyCleanHeaders].
^ self primitiveFail]].
"Reverse the Byte type objects if the data from opposite endian machine"
"Test top byte. $d on the Mac or $s on the PC. Rest of word is equal"
data = self imageSegmentVersion ifFalse: [
"Reverse the byte-type objects once"
+ segOop := self oopFromChunk: segmentWordArray + self baseHeaderSize + self wordSize.
- segOop := self oopFromChunk: segmentWordArray + BaseHeaderSize + BytesPerWord.
"Oop of first embedded object"
+ self byteSwapByteObjectsFrom: segOop to: endSeg + self wordSize].
- self byteSwapByteObjectsFrom: segOop to: endSeg + BytesPerWord].
"Proceed through the segment, remapping pointers..."
+ segOop := self oopFromChunk: segmentWordArray + self baseHeaderSize + self wordSize.
- segOop := self oopFromChunk: segmentWordArray + BaseHeaderSize + BytesPerWord.
[segOop <= endSeg] whileTrue:
[(self headerType: segOop) <= 1
ifTrue: ["This object has a class field (type = 0 or 1) -- start with that."
+ fieldPtr := segOop - self wordSize. doingClass := true]
- fieldPtr := segOop - BytesPerWord. doingClass := true]
ifFalse: ["No class field -- start with first data field"
+ fieldPtr := segOop + self baseHeaderSize. doingClass := false].
- fieldPtr := segOop + BaseHeaderSize. doingClass := false].
lastPtr := segOop + (self lastPointerOf: segOop). "last field"
lastPtr > endSeg ifTrue: [
DoAssertionChecks ifTrue: [self verifyCleanHeaders].
^ self primitiveFail "out of bounds"].
"Go through all oops, remapping them..."
[fieldPtr > lastPtr] whileFalse:
["Examine each pointer field"
fieldOop := self longAt: fieldPtr.
doingClass ifTrue:
[hdrTypeBits := self headerType: fieldPtr.
fieldOop := fieldOop - hdrTypeBits].
(self isIntegerObject: fieldOop)
ifTrue:
["Integer -- nothing to do"
+ fieldPtr := fieldPtr + self wordSize]
- fieldPtr := fieldPtr + BytesPerWord]
ifFalse:
[(fieldOop bitAnd: 3) = 0 ifFalse: [^ self primitiveFail "bad oop"].
(fieldOop bitAnd: 16r80000000) = 0
ifTrue: ["Internal pointer -- add segment offset"
mapOop := fieldOop + segmentWordArray]
ifFalse: ["External pointer -- look it up in outPointers"
outPtr := outPointerArray + (fieldOop bitAnd: 16r7FFFFFFF).
outPtr > lastOut ifTrue: [^ self primitiveFail "out of bounds"].
mapOop := self longAt: outPtr].
doingClass
ifTrue: [self longAt: fieldPtr put: mapOop + hdrTypeBits.
fieldPtr := fieldPtr + 8.
doingClass := false]
ifFalse: [self longAt: fieldPtr put: mapOop.
+ fieldPtr := fieldPtr + self wordSize].
- fieldPtr := fieldPtr + BytesPerWord].
segOop < youngStart
ifTrue: [self possibleRootStoreInto: segOop value: mapOop].
]].
segOop := self objectAfter: segOop].
"Again, proceed through the segment checking consistency..."
+ segOop := self oopFromChunk: segmentWordArray + self baseHeaderSize + self wordSize.
- segOop := self oopFromChunk: segmentWordArray + BaseHeaderSize + BytesPerWord.
[segOop <= endSeg] whileTrue:
[(self oopHasAcceptableClass: segOop) ifFalse: [^ self primitiveFail "inconsistency"].
+ fieldPtr := segOop + self baseHeaderSize. "first field"
- fieldPtr := segOop + BaseHeaderSize. "first field"
lastPtr := segOop + (self lastPointerOf: segOop). "last field"
"Go through all oops, remapping them..."
[fieldPtr > lastPtr] whileFalse:
["Examine each pointer field"
fieldOop := self longAt: fieldPtr.
(self oopHasAcceptableClass: fieldOop) ifFalse: [^ self primitiveFail "inconsistency"].
+ fieldPtr := fieldPtr + self wordSize].
- fieldPtr := fieldPtr + BytesPerWord].
segOop := self objectAfter: segOop].
"Truncate the segment word array to size = BytesPerWord (vers stamp only)"
extraSize := self extraHeaderBytes: segmentWordArray.
hdrTypeBits := self headerType: segmentWordArray.
extraSize = 8
+ ifTrue: [self longAt: segmentWordArray-extraSize put: self baseHeaderSize + self wordSize + hdrTypeBits]
- ifTrue: [self longAt: segmentWordArray-extraSize put: BaseHeaderSize + BytesPerWord + hdrTypeBits]
ifFalse: [header := self longAt: segmentWordArray.
self longAt: segmentWordArray
+ put: header - (header bitAnd: SizeMask) + self baseHeaderSize + self wordSize].
- put: header - (header bitAnd: SizeMask) + BaseHeaderSize + BytesPerWord].
"and return the roots array which was first in the segment"
DoAssertionChecks ifTrue: [self verifyCleanHeaders].
+ self pop: 3 thenPush: (self oopFromChunk: segmentWordArray + self baseHeaderSize + self wordSize).
- self pop: 3 thenPush: (self oopFromChunk: segmentWordArray + BaseHeaderSize + BytesPerWord).
!
Item was changed:
----- Method: NewspeakInterpreter>>primitiveNewMethod (in category 'compiled methods') -----
primitiveNewMethod
| header bytecodeCount class size theMethod literalCount |
header := self popStack.
bytecodeCount := self popInteger.
self success: (self isIntegerObject: header).
self successful ifFalse:
[self unPop: 2. ^nil].
class := self popStack.
+ size := (self literalCountOfMethodHeader: header) + 1 * self wordSize + bytecodeCount.
- size := (self literalCountOfMethodHeader: header) + 1 * BytesPerWord + bytecodeCount.
theMethod := self instantiateClass: class indexableSize: size.
self storePointerUnchecked: HeaderIndex ofObject: theMethod withValue: header.
literalCount := self literalCountOfMethodHeader: header.
1 to: literalCount do:
[:i | self storePointerUnchecked: i ofObject: theMethod withValue: nilObj].
self push: theMethod!
Item was changed:
----- Method: NewspeakInterpreter>>primitiveObjectPointsTo (in category 'object access primitives') -----
primitiveObjectPointsTo
| rcvr thang lastField |
thang := self popStack.
rcvr := self popStack.
(self isIntegerObject: rcvr) ifTrue: [^self pushBool: false].
lastField := self lastPointerOf: rcvr.
+ self baseHeaderSize to: lastField by: self wordSize do:
- BaseHeaderSize to: lastField by: BytesPerWord do:
[:i | (self longAt: rcvr + i) = thang
ifTrue: [^ self pushBool: true]].
self pushBool: false.!
Item was changed:
----- Method: NewspeakInterpreter>>primitiveShortAt (in category 'sound primitives') -----
primitiveShortAt
"Treat the receiver, which can be indexible by either bytes or words, as an array of signed 16-bit values. Return the contents of the given index. Note that the index specifies the i-th 16-bit entry, not the i-th byte or word."
| index rcvr sz addr value |
index := self stackIntegerValue: 0.
self successful ifFalse:
[^self primitiveFailFor: PrimErrBadArgument].
rcvr := self stackValue: 1.
((self isIntegerObject: rcvr)
or: [(self isWordsOrBytes: rcvr) not]) ifTrue:
[^self primitiveFailFor: PrimErrInappropriate].
+ sz := ((self sizeBitsOf: rcvr) - self baseHeaderSize) // 2. "number of 16-bit fields"
- sz := ((self sizeBitsOf: rcvr) - BaseHeaderSize) // 2. "number of 16-bit fields"
((index >= 1) and: [index <= sz]) ifFalse:
[^self primitiveFailFor: PrimErrBadIndex].
+ addr := rcvr + self baseHeaderSize + (2 * (index - 1)).
- addr := rcvr + BaseHeaderSize + (2 * (index - 1)).
value := self shortAt: addr.
self pop: 2 thenPushInteger: value!
Item was changed:
----- Method: NewspeakInterpreter>>primitiveShortAtPut (in category 'sound primitives') -----
primitiveShortAtPut
"Treat the receiver, which can be indexible by either bytes or words, as an array of signed 16-bit values. Set the contents of the given index to the given value. Note that the index specifies the i-th 16-bit entry, not the i-th byte or word."
| index rcvr sz addr value |
value := self stackIntegerValue: 0.
index := self stackIntegerValue: 1.
(self successful and: [(value >= -32768) and: [value <= 32767]]) ifFalse:
[^self primitiveFailFor: PrimErrBadArgument].
rcvr := self stackValue: 2.
((self isIntegerObject: rcvr) not and: [self isWordsOrBytes: rcvr]) ifFalse:
[^self primitiveFailFor: PrimErrInappropriate].
+ sz := ((self sizeBitsOf: rcvr) - self baseHeaderSize) // 2. "number of 16-bit fields"
- sz := ((self sizeBitsOf: rcvr) - BaseHeaderSize) // 2. "number of 16-bit fields"
(index >= 1 and: [index <= sz]) ifFalse:
[^self primitiveFailFor: PrimErrBadIndex].
(self isOopImmutable: rcvr) ifTrue:
[^self primitiveFailFor: PrimErrNoModification].
+ addr := rcvr + self baseHeaderSize + (2 * (index - 1)).
- addr := rcvr + BaseHeaderSize + (2 * (index - 1)).
self shortAt: addr put: value.
self pop: 3 thenPush: (self integerObjectOf: value) "pop all; return value"!
Item was changed:
----- Method: NewspeakInterpreter>>primitiveStoreStackp (in category 'object access primitives') -----
primitiveStoreStackp
"Atomic store into context stackPointer.
Also ensures that any newly accessible cells are initialized to nil "
| ctxt newStackp stackp |
ctxt := self stackValue: 1.
newStackp := self stackIntegerValue: 0.
self success: newStackp >= 0.
+ self success: newStackp <= (LargeContextSlots - CtxtTempFrameStart).
- self success: newStackp <= (LargeContextSize - BaseHeaderSize // BytesPerWord - CtxtTempFrameStart).
self successful ifFalse: [^ self primitiveFail].
stackp := self fetchStackPointerOf: ctxt.
+ "Nil any newly accessible cells"
+ stackp + 1 to: newStackp do:
+ [:i | self storePointerUnchecked: i + CtxtTempFrameStart - 1 ofObject: ctxt withValue: nilObj].
- newStackp > stackp ifTrue: ["Nil any newly accessible cells"
- stackp + 1 to: newStackp do: [:i | self storePointer: i + CtxtTempFrameStart - 1 ofObject: ctxt withValue: nilObj]].
self storeStackPointerValue: newStackp inContext: ctxt.
self pop: 1!
Item was changed:
----- Method: NewspeakInterpreter>>primitiveVMParameter (in category 'system control primitives') -----
primitiveVMParameter
"Behaviour depends on argument count:
0 args: return an Array of VM parameter values;
1 arg: return the indicated VM parameter;
2 args: set the VM indicated parameter.
VM parameters are numbered as follows:
1 end of old-space (0-based, read-only)
2 end of young-space (read-only)
3 end of memory (read-only)
4 allocationCount (read-only)
5 allocations between GCs (read-write)
6 survivor count tenuring threshold (read-write)
7 full GCs since startup (read-only)
8 total milliseconds in full GCs since startup (read-only)
9 incremental GCs since startup (read-only)
10 total milliseconds in incremental GCs since startup (read-only)
11 tenures of surving objects since startup (read-only)
12-20 specific to the translating VM
21 root table size (read-only)
22 root table overflows since startup (read-only)
23 bytes of extra memory to reserve for VM buffers, plugins, etc.
24 memory threshold above which shrinking object memory (rw)
25 memory headroom when growing object memory (rw)
26 interruptChecksEveryNms - force an ioProcessEvents every N milliseconds, in case the image is not calling getNextEvent often (rw)
27 number of times mark loop iterated for current IGC/FGC (read-only) includes ALL marking
28 number of times sweep loop iterated for current IGC/FGC (read-only)
29 number of times make forward loop iterated for current IGC/FGC (read-only)
30 number of times compact move loop iterated for current IGC/FGC (read-only)
31 number of grow memory requests (read-only)
32 number of shrink memory requests (read-only)
33 number of root table entries used for current IGC/FGC (read-only)
34 number of allocations done before current IGC/FGC (read-only)
35 number of survivor objects after current IGC/FGC (read-only)
36 millisecond clock when current IGC/FGC completed (read-only)
37 number of marked objects for Roots of the world, not including Root Table entries for current IGC/FGC (read-only)
38 milliseconds taken by current IGC (read-only)
39 Number of finalization signals for Weak Objects pending when current IGC/FGC completed (read-only)
40 BytesPerWord for this image
41 1 if the VM supports immutability, 0 otherwise
Note: Thanks to Ian Piumarta for this primitive."
| mem paramsArraySize result arg index ok |
mem := self startOfMemory.
paramsArraySize := 41.
argumentCount = 0 ifTrue: [
result := self instantiateClass: (self splObj: ClassArray) indexableSize: paramsArraySize.
0 to: paramsArraySize - 1 do:
[:i | self storePointerUnchecked: i ofObject: result withValue: ConstZero].
self storePointerUnchecked: 0 ofObject: result withValue:
(self integerObjectOf: youngStart - mem).
self storePointerUnchecked: 1 ofObject: result withValue:
(self integerObjectOf: freeBlock - mem).
self storePointerUnchecked: 2 ofObject: result withValue:
(self integerObjectOf: endOfMemory - mem).
self storePointerUnchecked: 3 ofObject: result withValue:
(self integerObjectOf: allocationCount).
self storePointerUnchecked: 4 ofObject: result withValue:
(self integerObjectOf: allocationsBetweenGCs).
self storePointerUnchecked: 5 ofObject: result withValue:
(self integerObjectOf: tenuringThreshold).
self storePointerUnchecked: 6 ofObject: result withValue:
(self integerObjectOf: statFullGCs).
self storePointerUnchecked: 7 ofObject: result withValue:
(self integerObjectOf: statFullGCUsecs + 500 // 1000).
self storePointerUnchecked: 8 ofObject: result withValue:
(self integerObjectOf: statIncrGCs).
self storePointerUnchecked: 9 ofObject: result withValue:
(self integerObjectOf: statIncrGCUsecs + 500 // 1000).
self storePointerUnchecked: 10 ofObject: result withValue:
(self integerObjectOf: statTenures).
self storePointerUnchecked: 20 ofObject: result withValue:
(self integerObjectOf: rootTableCount).
self storePointerUnchecked: 21 ofObject: result withValue:
(self integerObjectOf: statRootTableOverflows).
self storePointerUnchecked: 22 ofObject: result withValue:
(self integerObjectOf: extraVMMemory).
self storePointerUnchecked: 23 ofObject: result withValue:
(self integerObjectOf: shrinkThreshold).
self storePointerUnchecked: 24 ofObject: result withValue:
(self integerObjectOf: growHeadroom).
self storePointerUnchecked: 25 ofObject: result withValue:
(self integerObjectOf: interruptChecksEveryNms).
self storePointerUnchecked: 26 ofObject: result withValue:
(self integerObjectOf: statMarkCount).
self storePointerUnchecked: 27 ofObject: result withValue:
(self integerObjectOf: statSweepCount).
self storePointerUnchecked: 28 ofObject: result withValue:
(self integerObjectOf: statMkFwdCount).
self storePointerUnchecked: 29 ofObject: result withValue:
(self integerObjectOf: statCompMoveCount).
self storePointerUnchecked: 30 ofObject: result withValue:
(self integerObjectOf: statGrowMemory).
self storePointerUnchecked: 31 ofObject: result withValue:
(self integerObjectOf: statShrinkMemory).
self storePointerUnchecked: 32 ofObject: result withValue:
(self integerObjectOf: statRootTableCount).
self storePointerUnchecked: 33 ofObject: result withValue:
(self integerObjectOf: statAllocationCount).
self storePointerUnchecked: 34 ofObject: result withValue:
(self integerObjectOf: statSurvivorCount).
self storePointerUnchecked: 35 ofObject: result withValue:
(self integerObjectOf: statGCEndTime).
self storePointerUnchecked: 36 ofObject: result withValue:
(self integerObjectOf: statSpecialMarkCount).
self storePointerUnchecked: 37 ofObject: result withValue:
(self integerObjectOf: statIGCDeltaUsecs + 500 // 1000).
self storePointerUnchecked: 38 ofObject: result withValue:
(self integerObjectOf: statPendingFinalizationSignals).
self storePointerUnchecked: 39 ofObject: result withValue:
+ (self integerObjectOf: self wordSize).
- (self integerObjectOf: BytesPerWord).
self storePointerUnchecked: 40 ofObject: result withValue:
(self integerObjectOf: ImmutabilityBit ~= 0).
self pop: 1 thenPush: result.
^nil].
argumentCount = 1
ifTrue: [index := self stackTop]
ifFalse: [argumentCount = 2
ifTrue: [index := self stackValue: 1]
ifFalse: [^self primitiveFail]].
(self isIntegerObject: index) ifFalse: [^self primitiveFail].
index := self integerValueOf: index.
(index < 1 or: [index > paramsArraySize]) ifTrue: [^self primitiveFail].
"read VM parameter"
index = 1 ifTrue: [result := youngStart - mem].
index = 2 ifTrue: [result := freeBlock - mem].
index = 3 ifTrue: [result := endOfMemory - mem].
index = 4 ifTrue: [result := allocationCount].
index = 5 ifTrue: [result := allocationsBetweenGCs].
index = 6 ifTrue: [result := tenuringThreshold].
index = 7 ifTrue: [result := statFullGCs].
index = 8 ifTrue: [result := statFullGCUsecs + 500 // 1000].
index = 9 ifTrue: [result := statIncrGCs].
index = 10 ifTrue: [result := statIncrGCUsecs + 500 // 1000].
index = 11 ifTrue: [result := statTenures].
((index >= 12) and: [index <= 20]) ifTrue: [result := 0].
index = 21 ifTrue: [result := rootTableCount].
index = 22 ifTrue: [result := statRootTableOverflows].
index = 23 ifTrue: [result := extraVMMemory].
index = 24 ifTrue: [result := shrinkThreshold].
index = 25 ifTrue: [result := growHeadroom].
index = 26 ifTrue: [result := interruptChecksEveryNms].
index = 27 ifTrue: [result := statMarkCount].
index = 28 ifTrue: [result := statSweepCount].
index = 29 ifTrue: [result := statMkFwdCount].
index = 30 ifTrue: [result := statCompMoveCount].
index = 31 ifTrue: [result := statGrowMemory].
index = 32 ifTrue: [result := statShrinkMemory].
index = 33 ifTrue: [result := statRootTableCount].
index = 34 ifTrue: [result := statAllocationCount].
index = 35 ifTrue: [result := statSurvivorCount].
index = 36 ifTrue: [result := statGCEndTime].
index = 37 ifTrue: [result := statSpecialMarkCount].
index = 38 ifTrue: [result := statIGCDeltaUsecs + 500 // 1000].
index = 39 ifTrue: [result := statPendingFinalizationSignals].
+ index = 40 ifTrue: [result := self wordSize].
- index = 40 ifTrue: [result := BytesPerWord].
index = 41 ifTrue: [result := ImmutabilityBit ~= 0].
argumentCount = 1 ifTrue:
[self pop: 2 thenPush: (self integerObjectOf: result).
^nil].
"write a VM parameter"
arg := self stackTop.
(self isIntegerObject: arg) ifFalse: [^self primitiveFail].
arg := self integerValueOf: arg.
ok := false.
index = 5 ifTrue: [
allocationsBetweenGCs := arg.
ok := true].
index = 6 ifTrue: [
tenuringThreshold := arg.
ok := true].
index = 23 ifTrue: [
extraVMMemory := arg.
ok := true].
(index = 24 and: [arg > 0]) ifTrue:[
shrinkThreshold := arg.
ok := true].
(index = 25 and: [arg > 0]) ifTrue:[
growHeadroom := arg.
ok := true].
(index = 26 and: [arg > 1]) ifTrue:[
interruptChecksEveryNms := arg.
ok := true].
ok ifTrue: [
self pop: 3 thenPush: (self integerObjectOf: result). "return old value"
^ nil].
self primitiveFail. "attempting to write a read-only parameter"
!
Item was changed:
----- Method: NewspeakInterpreter>>primitiveVMPath (in category 'system control primitives') -----
primitiveVMPath
"Return a string containing the path name of VM's directory."
| s sz |
sz := self vmPathSize.
s := self instantiateClass: (self splObj: ClassByteString) indexableSize: sz.
+ self vmPathGet: (s + self baseHeaderSize) Length: sz.
- self vmPathGet: (s + BaseHeaderSize) Length: sz.
self pop: 1 thenPush: s.
!
Item was changed:
----- Method: NewspeakInterpreter>>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'].
((self sizeBitsOf: classOop) = metaclassSizeBits
+ and: [metaclassSizeBits > (thisClassIndex * self wordSize)]) "(Metaclass instSize * 4)"
- and: [metaclassSizeBits > (thisClassIndex * BytesPerWord)]) "(Metaclass instSize * 4)"
ifTrue: [self printNameOfClass: (self fetchPointer: thisClassIndex ofObject: classOop) count: cnt - 1.
self print: ' class']
ifFalse: [self printStringOf: (self fetchPointer: classNameIndex ofObject: classOop)]!
Item was changed:
----- Method: NewspeakInterpreter>>printOop: (in category 'debug printing') -----
printOop: oop
| cls fmt lastIndex startIP bytecodesPerLine |
<inline: false>
self printHex: oop.
(self isIntegerObject: oop) ifTrue:
[^self
cCode: 'printf("=%ld\n", (long)integerValueOf(oop))'
inSmalltalk: [self print: (self shortPrint: oop); cr]].
(oop between: self startOfMemory and: freeBlock) ifFalse:
[self printHex: oop; print: ' is not on the heap'; cr.
^nil].
+ (oop bitAnd: (self wordSize - 1)) ~= 0 ifTrue:
- (oop bitAnd: (BytesPerWord - 1)) ~= 0 ifTrue:
[self printHex: oop; print: ' is misaligned'; cr.
^nil].
(self isFreeObject: oop) ifTrue:
[self print: ' free chunk of size '; printNum: (self sizeOfFree: oop); cr.
^nil].
self print: ': a(n) '.
self printNameOfClass: (cls := self fetchClassOfNonImm: oop) count: 5.
cls = (self splObj: ClassFloat) ifTrue:
[self cr; printFloat: (self dbgFloatValueOf: oop); cr.
^nil].
fmt := self formatOf: oop.
fmt > 4 ifTrue:
[self print: ' nbytes '; printNum: (self byteSizeOf: oop)].
self cr.
(fmt > 4 and: [fmt < 12]) ifTrue:
[(self isWords: oop) ifTrue:
+ [lastIndex := 64 min: ((self byteSizeOf: oop) / self wordSize).
- [lastIndex := 64 min: ((self byteSizeOf: oop) / BytesPerWord).
lastIndex > 0 ifTrue:
[1 to: lastIndex do:
[:index|
self space; printHex: (self 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 := (self lastPointerOf: oop) / self wordSize).
- lastIndex := 64 min: (startIP := (self lastPointerOf: oop) / BytesPerWord).
lastIndex > 0 ifTrue:
[1 to: lastIndex do:
[:index|
self cCode: 'printHex(fetchPointerofObject(index - 1, oop)); putchar('' '')'
inSmalltalk: [self space; printHex: (self fetchPointer: index - 1 ofObject: oop); space.
self print: (self shortPrint: (self fetchPointer: index - 1 ofObject: oop))].
(index \\ self elementsPerPrintOopLine) = 0 ifTrue:
[self cr]].
(lastIndex \\ self elementsPerPrintOopLine) = 0 ifFalse:
[self cr]].
(self isCompiledMethod: oop)
ifFalse:
[startIP > 64 ifTrue: [self print: '...'; cr]]
ifTrue:
+ [startIP := startIP * self wordSize + 1.
- [startIP := startIP * BytesPerWord + 1.
lastIndex := self lengthOf: oop.
lastIndex - startIP > 100 ifTrue:
[lastIndex := startIP + 100].
bytecodesPerLine := 10.
startIP to: lastIndex do:
[:index| | byte |
byte := self 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: NewspeakInterpreter>>printOopShortInner: (in category 'debug printing') -----
printOopShortInner: oop
| classOop name nameLen |
<var: #name type: #'char *'>
<inline: true>
self printChar: $=.
(self isIntegerObject: oop) ifTrue:
[self printNum: (self integerValueOf: oop);
printChar: $(;
printHex: (self integerValueOf: oop);
printChar: $).
^nil].
(oop between: self startOfMemory and: freeBlock) ifFalse:
[self printHex: oop; print: ' is not on the heap'.
^nil].
+ (oop bitAnd: (self wordSize - 1)) ~= 0 ifTrue:
- (oop bitAnd: (BytesPerWord - 1)) ~= 0 ifTrue:
[self printHex: oop; print: ' is misaligned'.
^nil].
(self isFloatObject: oop) ifTrue:
[self printFloat: (self dbgFloatValueOf: oop).
^nil].
classOop := self fetchClassOf: oop.
(self sizeBitsOf: classOop) = metaclassSizeBits ifTrue:
[self printNameOfClass: oop count: 5.
^nil].
oop = self nilObject ifTrue: [self print: 'nil'. ^nil].
oop = self trueObject ifTrue: [self print: 'true'. ^nil].
oop = self 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) = 0 "strncmp is weird" ifTrue:
[self printChar: $"; printStringOf: oop; printChar: $".
^nil].
(self str: name n: 'ByteSymbol' cmp: 10) = 0 "strncmp is weird" ifTrue:
[self printChar: $#; printStringOf: oop.
^nil]].
(nameLen = 9 and: [(self str: name n: 'Character' cmp: 9) = 0]) ifTrue:
[self printChar: $$; printChar: (self integerValueOf: (self 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: NewspeakInterpreter>>printStringOf: (in category 'debug printing') -----
printStringOf: oop
| fmt cnt i |
<inline: false>
(self isIntegerObject: oop) ifTrue:
[^nil].
(oop between: self startOfMemory and: freeBlock) ifFalse:
[^nil].
+ (oop bitAnd: (self wordSize - 1)) ~= 0 ifTrue:
- (oop bitAnd: (BytesPerWord - 1)) ~= 0 ifTrue:
[^nil].
fmt := self formatOf: oop.
fmt < 8 ifTrue: [ ^nil ].
cnt := 100 min: (self lengthOf: oop).
i := 0.
((self is: oop
instanceOf: (self splObj: ClassByteArray)
compactClassIndex: 0)
or: [(self is: oop
instanceOf: (self splObj: ClassLargePositiveInteger)
compactClassIndex: ClassLargePositiveIntegerCompactIndex)
or: [(self is: oop
instanceOf: (self splObj: ClassLargeNegativeInteger)
compactClassIndex: ClassLargeNegativeIntegerCompactIndex)]])
ifTrue:
[[i < cnt] whileTrue: [
self printHex: (self fetchByte: i ofObject: oop).
i := i + 1]]
ifFalse:
[[i < cnt] whileTrue: [
self printChar: (self fetchByte: i ofObject: oop).
i := i + 1]].
self flush!
Item was changed:
----- Method: NewspeakInterpreter>>push: (in category 'internal interpreter access') -----
push: object
| sp |
+ self longAt: (sp := stackPointer + self wordSize) put: object.
- self longAt: (sp := stackPointer + BytesPerWord) put: object.
stackPointer := sp.!
Item was changed:
----- Method: NewspeakInterpreter>>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 |
+ self wordSize == 4
- BytesPerWord == 4
ifTrue: [imageFormatVersionNumber := 6504]
ifFalse: [imageFormatVersionNumber := 68002].
numArgsNumCopied := self fetchByte.
numArgs := numArgsNumCopied bitAnd: 16rF.
numCopied := numArgsNumCopied bitShift: -4.
"Split blockSize := (self fetchByte * 256) + self fetchByte. into two because evaluation order in C is undefined."
blockSize := self fetchByte << 8.
blockSize := blockSize + self fetchByte.
self externalizeIPandSP. "This is a pain."
newClosure := self
closureNumArgs: numArgs
+ instructionPointer: ((self oopForPointer: localIP) + 2 - (method+self baseHeaderSize))
- instructionPointer: ((self oopForPointer: localIP) + 2 - (method+BaseHeaderSize))
numCopiedValues: numCopied.
self internalizeIPandSP.
"Assume: have just allocated a new closure; it must be young. Thus, can use unchecked stores."
self storePointerUnchecked: ClosureOuterContextIndex ofObject: newClosure withValue: activeContext.
reclaimableContextCount := 0. "The closure refers to thisContext so it can't be reclaimed."
numCopied > 0 ifTrue:
[0 to: numCopied - 1 do:
[:i|
"Assume: have just allocated a new BlockClosure; it must be young.
Thus, can use unchecked stores."
self storePointerUnchecked: i + ClosureFirstCopiedValueIndex
ofObject: newClosure
withValue: (self internalStackValue: numCopied - i - 1)].
self internalPop: numCopied].
localIP := localIP + blockSize.
self fetchNextBytecode.
self internalPush: newClosure!
Item was changed:
----- Method: NewspeakInterpreter>>readImageFromFile:HeapSize:StartingAt: (in category 'image save/restore') -----
readImageFromFile: f HeapSize: desiredHeapSize StartingAt: imageOffset
"Read an image from the given file stream, allocating the given amount of memory to its object heap. Fail if the image has an unknown format or requires more than the given amount of memory."
"Details: This method detects when the image was stored on a machine with the opposite byte ordering from this machine and swaps the bytes automatically. Furthermore, it allows the header information to start 512 bytes into the file, since some file transfer programs for the Macintosh apparently prepend a Mac-specific header of this size. Note that this same 512 bytes of prefix area could also be used to store an exec command on Unix systems, allowing one to launch Smalltalk by invoking the image name as a command."
"This code is based on C code by Ian Piumarta and Smalltalk code by Tim Rowledge. Many thanks to both of you!!!!"
| swapBytes headerStart headerSize dataSize oldBaseAddr minimumMemory memStart bytesRead bytesToShift heapSize |
<var: #f type: 'sqImageFile '>
<var: #memStart type: 'usqInt'>
<var: #desiredHeapSize type: 'usqInt'>
<var: #headerStart type: 'squeakFileOffsetType '>
<var: #dataSize type: 'size_t '>
<var: #imageOffset type: 'squeakFileOffsetType '>
+ metaclassSizeBits := 7 * self wordSize. "guess (Metaclass instSize+1 * 4)"
- metaclassSizeBits := 7 * BytesPerWord. "guess (Metaclass instSize+1 * 4)"
swapBytes := self checkImageVersionFrom: f startingAt: imageOffset.
+ headerStart := (self sqImageFilePosition: f) - self wordSize. "record header start position"
- headerStart := (self sqImageFilePosition: f) - BytesPerWord. "record header start position"
headerSize := self getLongFromFile: f swap: swapBytes.
dataSize := self getLongFromFile: f swap: swapBytes.
oldBaseAddr := self getLongFromFile: f swap: swapBytes.
specialObjectsOop := self getLongFromFile: f swap: swapBytes.
lastHash := self getLongFromFile: f swap: swapBytes.
savedWindowSize := self getLongFromFile: f swap: swapBytes.
fullScreenFlag := self getLongFromFile: f swap: swapBytes.
extraVMMemory := self getLongFromFile: f swap: swapBytes.
lastHash = 0 ifTrue: [
"lastHash wasn't stored (e.g. by the cloner); use 999 as the seed"
lastHash := 999].
"decrease Squeak object heap to leave extra memory for the VM"
heapSize := self cCode: 'reserveExtraCHeapBytes(desiredHeapSize, extraVMMemory)'.
"compare memory requirements with availability".
minimumMemory := dataSize + 100000. "need at least 100K of breathing room"
heapSize < minimumMemory ifTrue: [
self insufficientMemorySpecifiedError].
"allocate a contiguous block of memory for the Squeak heap"
memory := self
allocateMemory: heapSize
minimum: minimumMemory
imageFile: f
headerSize: headerSize.
memory = nil ifTrue: [self insufficientMemoryAvailableError].
memStart := self startOfMemory.
memoryLimit := (memStart + heapSize) - 24. "decrease memoryLimit a tad for safety"
endOfMemory := memStart + dataSize.
"position file after the header"
self sqImageFile: f Seek: headerStart + headerSize.
"read in the image in bulk, then swap the bytes if necessary"
bytesRead := self cCode: 'sqImageFileRead(pointerForOop(memory), sizeof(unsigned char), dataSize, f)'.
bytesRead ~= dataSize ifTrue: [self unableToReadImageError].
swapBytes ifTrue: [self reverseBytesInImage].
"compute difference between old and new memory base addresses"
bytesToShift := memStart - oldBaseAddr.
self initializeInterpreter: bytesToShift. "adjusts all oops to new location"
^dataSize!
Item was changed:
----- Method: NewspeakInterpreter>>reverseDisplayFrom:to: (in category 'I/O primitive support') -----
reverseDisplayFrom: startIndex to: endIndex
"Reverse the given range of Display words (at different bit
depths, this will reverse different numbers of pixels). Used to
give feedback during VM activities such as garbage
collection when debugging. It is assumed that the given
word range falls entirely within the first line of the Display."
| displayObj dispBitsPtr w reversed |
displayObj := self splObj: TheDisplay.
((self isPointers: displayObj) and: [(self lengthOf: displayObj) >= 4]) ifFalse: [^ nil].
w := self fetchInteger: 1 ofObject: displayObj.
dispBitsPtr := self fetchPointer: 0 ofObject: displayObj.
(self isIntegerObject: dispBitsPtr) ifTrue: [^ nil].
+ dispBitsPtr := dispBitsPtr + self baseHeaderSize.
- dispBitsPtr := dispBitsPtr + BaseHeaderSize.
dispBitsPtr + (startIndex * 4) to: dispBitsPtr + (endIndex * 4) by: 4
do: [:ptr |
reversed := (self long32At: ptr) bitXor: 4294967295.
self longAt: ptr put: reversed].
self initPrimCall.
self displayBitsOf: displayObj Left: 0 Top: 0 Right: w Bottom: 1.
self ioForceDisplayUpdate!
Item was changed:
----- Method: NewspeakInterpreter>>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 methodHeaderOf: method) bitAnd: LargeContextBit) ~= 0
+ ifTrue: [cntxSize := LargeContextSlots - CtxtTempFrameStart]
+ ifFalse: [cntxSize := SmallContextSlots - CtxtTempFrameStart].
- ifTrue: [cntxSize := LargeContextSize / BytesPerWord - ReceiverIndex]
- ifFalse: [cntxSize := SmallContextSize / BytesPerWord - ReceiverIndex].
^self stackPointerIndex + n <= cntxSize!
Item was changed:
----- Method: NewspeakInterpreter>>sendInvokeCallback:Stack:Registers:Jmpbuf: (in category 'callback support') -----
sendInvokeCallback: thunkPtr Stack: stackPtr Registers: regsPtr Jmpbuf: jmpBufPtr
"Send the 4 argument callback message invokeCallback:stack:registers:jmpbuf:
to Alien class with the supplied args. The arguments are raw C addresses
and are converted to integer objects on the way."
| where |
<export: true>
self pushRemappableOop: (self positive32BitIntegerFor: jmpBufPtr).
self pushRemappableOop: (self positive32BitIntegerFor: regsPtr).
self pushRemappableOop: (self positive32BitIntegerFor: stackPtr).
self pushRemappableOop: (self positive32BitIntegerFor: thunkPtr).
receiver := self splObj: ClassAlien.
lkupClass := self fetchClassOfNonImm: receiver.
messageSelector := self splObj: SelectorInvokeCallback.
(self lookupInMethodCacheSel: messageSelector class: lkupClass) ifFalse:
[(self lookupMethodNoMNUEtcInClass: lkupClass) ifFalse:
[^false]].
((self argumentCountOf: newMethod) = 4
and: [primitiveFunctionPointer = 0]) ifFalse:
[^false].
self storeContextRegisters: activeContext.
self justActivateNewMethod.
+ where := activeContext + self baseHeaderSize + (ReceiverIndex << self shiftForWord).
+ self longAt: where + (1 << self shiftForWord) put: self popRemappableOop.
+ self longAt: where + (2 << self shiftForWord) put: self popRemappableOop.
+ self longAt: where + (3 << self shiftForWord) put: self popRemappableOop.
+ self longAt: where + (4 << self shiftForWord) put: self popRemappableOop.
- where := activeContext + BaseHeaderSize + (ReceiverIndex << ShiftForWord).
- self longAt: where + (1 << ShiftForWord) put: self popRemappableOop.
- self longAt: where + (2 << ShiftForWord) put: self popRemappableOop.
- self longAt: where + (3 << ShiftForWord) put: self popRemappableOop.
- self longAt: where + (4 << ShiftForWord) put: self popRemappableOop.
self interpret.
"not reached"
^true!
Item was changed:
----- Method: NewspeakInterpreter>>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 *'>
| relativeSP |
receiver := self splObj: ClassAlien.
lkupClass := self fetchClassOfNonImm: receiver.
messageSelector := self splObj: SelectorInvokeCallback.
(self lookupInMethodCacheSel: messageSelector class: lkupClass) ifFalse:
[(self lookupMethodNoMNUEtcInClass: lkupClass) ~= 0 ifTrue:
[^false]].
primitiveFunctionPointer ~= 0 ifTrue:
[^false].
self storeContextRegisters: activeContext.
self justActivateNewMethod.
relativeSP := stackPointer - activeContext.
+ stackPointer := activeContext + self baseHeaderSize + (ReceiverIndex * self wordSize).
+ self cppIf: self wordSize = 8
- stackPointer := activeContext + BaseHeaderSize + (ReceiverIndex * BytesPerWord).
- self cppIf: 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)].
stackPointer := activeContext + relativeSP.
self assert: (self validInstructionPointer: instructionPointer inMethod: method).
self interpret.
"not reached"
^true!
Item was changed:
----- Method: NewspeakInterpreter>>shortPrintOop: (in category 'debug printing') -----
shortPrintOop: oop
<inline: false>
self printHex: oop.
(self isIntegerObject: oop) ifTrue:
[^self cCode: 'printf("=%ld\n", (long)integerValueOf(oop))' inSmalltalk: [self print: (self shortPrint: oop); cr]].
(oop between: self startOfMemory and: freeBlock) ifFalse:
[self printHex: oop; print: ' is not on the heap'; cr.
^nil].
+ (oop bitAnd: (self wordSize - 1)) ~= 0 ifTrue:
- (oop bitAnd: (BytesPerWord - 1)) ~= 0 ifTrue:
[self printHex: oop; print: ' is misaligned'; cr.
^nil].
self print: ': a(n) '.
self printNameOfClass: (self fetchClassOf: oop) count: 5.
self cr!
Item was changed:
----- Method: NewspeakInterpreter>>sizeFieldOfAlien: (in category 'primitive support') -----
sizeFieldOfAlien: alienObj
"Answer the first field of alienObj which is assumed to be an Alien of at least 8 bytes"
<inline: true>
+ ^self longAt: alienObj + self baseHeaderSize!
- ^self longAt: alienObj + BaseHeaderSize!
Item was changed:
----- Method: NewspeakInterpreter>>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) - BaseHeaderSize.
(self isWordsOrBytes: oop) ifFalse: [
self primitiveFail.
^0].
^self lengthOf: oop
!
Item was changed:
----- Method: NewspeakInterpreter>>slowPrimitiveResponse (in category 'primitive support') -----
slowPrimitiveResponse
"NB: tpr removed the timer checks here and moved them to the primitiveExternalCall method.
We make the possibly unwarranted assumption that numbered prims are quick and external prims are slow."
| nArgs deltaIfSuccess savedContext |
<inline: true>
FailImbalancedPrimitives ifTrue:
[savedContext := activeContext.
nArgs := argumentCount.
+ deltaIfSuccess := stackPointer - (argumentCount * self bytesPerOop) - activeContext].
- deltaIfSuccess := stackPointer - (argumentCount * BytesPerOop) - activeContext].
self fastLogPrim: messageSelector.
self initPrimCall.
self dispatchFunctionPointer: primitiveFunctionPointer.
(FailImbalancedPrimitives
and: [self successful
and: [savedContext = activeContext]]) ifTrue:"Don't fail if primitive has done something radical, e.g. perform:"
[stackPointer - activeContext ~= deltaIfSuccess ifTrue:
[self flag: 'Would be nice to make this a message send of e.g. unbalancedPrimitive to the current process or context'.
self warning: 'failing primitive due to unbalanced stack'.
"This is necessary but insufficient; the result may still have been written to the stack.
At least we'll know something is wrong."
+ stackPointer := activeContext + deltaIfSuccess + (nArgs * self bytesPerOop).
- stackPointer := activeContext + deltaIfSuccess + (nArgs * BytesPerOop).
self failUnbalancedPrimitive]].
^ self successful!
Item was changed:
----- Method: NewspeakInterpreter>>snapshotCleanUp (in category 'image save/restore') -----
snapshotCleanUp
"Clean up right before saving an image, sweeping memory and:
* nilling out all fields of contexts above the stack pointer.
* flushing external primitives
* clearing the root bit of any object in the root table "
| oop header fmt sz |
oop := self firstObject.
[oop < endOfMemory]
whileTrue: [(self isFreeObject: oop)
ifFalse: [header := self longAt: oop.
fmt := header >> 8 bitAnd: 15.
"Clean out context"
(fmt = 3 and: [self isContextHeader: header])
ifTrue: [sz := self sizeBitsOf: oop.
+ (self lastPointerOf: oop) + self wordSize
+ to: sz - self baseHeaderSize by: self wordSize
- (self lastPointerOf: oop) + BytesPerWord
- to: sz - BaseHeaderSize by: BytesPerWord
do: [:i | self longAt: oop + i put: nilObj]].
"Clean out external functions"
fmt >= 12
ifTrue: ["This is a compiled method"
(self primitiveIndexOf: oop) = PrimitiveExternalCallIndex
ifTrue: ["It's primitiveExternalCall"
self flushExternalPrimitiveOf: oop]]].
oop := self objectAfter: oop].
self clearRootsTable!
Item was changed:
----- Method: NewspeakInterpreter>>stackFloatValue: (in category 'internal interpreter access') -----
stackFloatValue: offset
<returnTypeC: #double>
+ ^self floatValueOf: (self longAt: stackPointer - (offset*self wordSize))!
- ^self floatValueOf: (self longAt: stackPointer - (offset*BytesPerWord))!
Item was changed:
----- Method: NewspeakInterpreter>>stackIntegerValue: (in category 'internal interpreter access') -----
stackIntegerValue: offset
| integerPointer |
+ integerPointer := self longAt: stackPointer - (offset*self wordSize).
- integerPointer := self longAt: stackPointer - (offset*BytesPerWord).
^self checkedIntegerValueOf: integerPointer!
Item was changed:
----- Method: NewspeakInterpreter>>stackObjectValue: (in category 'internal interpreter access') -----
stackObjectValue: offset
"Ensures that the given object is a real object, not a SmallInteger."
| oop |
+ oop := self longAt: stackPointer - (offset * self wordSize).
- oop := self longAt: stackPointer - (offset * BytesPerWord).
(self isIntegerObject: oop) ifTrue: [self primitiveFail. ^ nil].
^ oop
!
Item was changed:
----- Method: NewspeakInterpreter>>stackPointerIndexFor:context: (in category 'internal interpreter access') -----
stackPointerIndexFor: sp context: ctxt
"Return the 0-based index rel to the current context.
(This is what stackPointer used to be before conversion to pointer"
<api>
<inline: true>
+ ^ (sp - ctxt - self baseHeaderSize) >> self shiftForWord!
- ^ (sp - ctxt - BaseHeaderSize) >> ShiftForWord!
Item was changed:
----- Method: NewspeakInterpreter>>stackPositiveMachineIntegerValue: (in category 'internal interpreter access') -----
stackPositiveMachineIntegerValue: offset
<api>
| integerPointer |
+ integerPointer := self longAt: stackPointer - (offset*self wordSize).
- integerPointer := self longAt: stackPointer - (offset*BytesPerWord).
^self positiveMachineIntegerValueOf: integerPointer!
Item was changed:
----- Method: NewspeakInterpreter>>stackSignedMachineIntegerValue: (in category 'internal interpreter access') -----
stackSignedMachineIntegerValue: offset
<api>
| integerPointer |
+ integerPointer := self longAt: stackPointer - (offset*self wordSize).
- integerPointer := self longAt: stackPointer - (offset*BytesPerWord).
^self signedMachineIntegerValueOf: integerPointer!
Item was changed:
----- Method: NewspeakInterpreter>>stackValue: (in category 'internal interpreter access') -----
stackValue: offset
+ ^ self longAt: stackPointer - (offset*self wordSize)!
- ^ self longAt: stackPointer - (offset*BytesPerWord)!
Item was changed:
----- Method: NewspeakInterpreter>>stackValue:put: (in category 'internal interpreter access') -----
stackValue: offset put: oop
+ ^self longAt: stackPointer - (offset*self wordSize)
- ^self longAt: stackPointer - (offset*BytesPerWord)
put: oop!
Item was changed:
----- Method: NewspeakInterpreter>>startOfAlienData: (in category 'primitive support') -----
startOfAlienData: oop
"Answer the start of the Alien's data or fail if oop is not an Alien."
<api>
<returnTypeC: #'void *'>
(self is: oop KindOfClass: (self splObj: ClassAlien)) ifFalse:
[self primitiveFailFor: PrimErrBadArgument.
^0].
^self cCoerceSimple: ((self sizeFieldOfAlien: oop) > 0
+ ifTrue: [oop + self baseHeaderSize + self bytesPerOop]
+ ifFalse: [self longAt: oop + self baseHeaderSize + self bytesPerOop])
- ifTrue: [oop + BaseHeaderSize + BytesPerOop]
- ifFalse: [self longAt: oop + BaseHeaderSize + BytesPerOop])
to: #'void *'!
Item was changed:
----- Method: NewspeakInterpreter>>storeContextRegisters: (in category 'contexts') -----
storeContextRegisters: activeCntx
"Note: internalStoreContextRegisters: should track changes to this method."
"InstructionPointer is a pointer variable equal to
method oop + ip + BaseHeaderSize
-1 for 0-based addressing of fetchByte
-1 because it gets incremented BEFORE fetching currentByte"
<inline: true>
self storePointerUnchecked: InstructionPointerIndex ofObject: activeCntx
+ withValue: (self integerObjectOf: (instructionPointer - method - (self baseHeaderSize - 2))).
- withValue: (self integerObjectOf: (instructionPointer - method - (BaseHeaderSize - 2))).
self storePointerUnchecked: StackPointerIndex ofObject: activeCntx
withValue: (self integerObjectOf: (self stackPointerIndex - TempFrameStart + 1)).
!
Item was changed:
----- Method: NewspeakInterpreter>>transfer:fromIndex:ofObject:toIndex:ofObject: (in category 'utilities') -----
transfer: count fromIndex: firstFrom ofObject: fromOop toIndex: firstTo ofObject: toOop
"Transfer the specified fullword fields, as from calling context to called context"
"Assume: beRootIfOld: will be called on toOop."
| fromIndex toIndex lastFrom |
<inline: true>
self flag: #Dan. "Need to check all senders before converting this for 64 bits"
+ fromIndex := fromOop + (firstFrom * self wordSize).
+ toIndex := toOop + (firstTo * self wordSize).
+ lastFrom := fromIndex + (count * self wordSize).
- fromIndex := fromOop + (firstFrom * BytesPerWord).
- toIndex := toOop + (firstTo * BytesPerWord).
- lastFrom := fromIndex + (count * BytesPerWord).
[self oop: fromIndex isLessThan: lastFrom]
+ whileTrue: [fromIndex := fromIndex + self wordSize.
+ toIndex := toIndex + self wordSize.
- whileTrue: [fromIndex := fromIndex + BytesPerWord.
- toIndex := toIndex + BytesPerWord.
self
longAt: toIndex
put: (self longAt: fromIndex)]!
Item was changed:
----- Method: NewspeakInterpreter>>unPop: (in category 'internal interpreter access') -----
unPop: nItems
+ stackPointer := stackPointer + (nItems*self wordSize)!
- stackPointer := stackPointer + (nItems*BytesPerWord)!
Item was changed:
----- Method: NewspeakInterpreter>>wordSwapped: (in category 'image save/restore') -----
wordSwapped: w
"Return the given 64-bit integer with its halves in the reverse order."
+ self wordSize = 8 ifFalse: [self error: 'This cannot happen.'].
- BytesPerWord = 8 ifFalse: [self error: 'This cannot happen.'].
^ ((w bitShift: Byte4ShiftNegated) bitAnd: Bytes3to0Mask)
+ ((w bitShift: Byte4Shift ) bitAnd: Bytes7to4Mask)
!
Item was changed:
----- Method: NewspeakInterpreterSimulator>>clipboardWrite:From:At: (in category 'I/O primitives') -----
clipboardWrite: sz From: actualDataAddress At: ignored
+ Clipboard clipboardText: (self stringOf: actualDataAddress - self baseHeaderSize)!
- Clipboard clipboardText: (self stringOf: actualDataAddress - BaseHeaderSize)!
Item was changed:
----- Method: NewspeakInterpreterSimulator>>firstIndexableField: (in category 'memory access') -----
firstIndexableField: oop
"NOTE: overridden from ObjectMemory to add coercion to CArray, so please duplicate any changes"
| hdr fmt totalLength fixedFields |
<returnTypeC: #'void *'>
hdr := self baseHeader: oop.
fmt := self formatOfHeader: hdr.
fmt <= 4 ifTrue: "<= 4 pointer"
["pointer; may need to delve into the class format word"
totalLength := self lengthOf: oop baseHeader: hdr format: fmt.
fixedFields := self fixedFieldsOf: oop format: fmt length: totalLength.
+ ^self cCoerce: (self pointerForOop: oop + self baseHeaderSize + (fixedFields << self shiftForWord)) to: 'oop *'].
- ^self cCoerce: (self pointerForOop: oop + BaseHeaderSize + (fixedFields << ShiftForWord)) to: 'oop *'].
^self
+ cCoerce: (self pointerForOop: oop + self baseHeaderSize)
- cCoerce: (self pointerForOop: oop + BaseHeaderSize)
to: (fmt < 8
ifTrue: [fmt = 6
ifTrue: ["32 bit field objects" 'int *']
ifFalse: ["full word objects (bits)" 'oop *']]
ifFalse: ["byte objects (including CompiledMethod" 'char *'])!
Item was changed:
----- Method: NewspeakInterpreterSimulator>>longPrint: (in category 'debug support') -----
longPrint: oop
| lastPtr val lastLong hdrType prevVal |
(self isIntegerObject: oop) ifTrue: [^ self shortPrint: oop].
^ String streamContents:
[:strm |
+ lastPtr := 64*self wordSize min: (self lastPointerOf: oop).
- lastPtr := 64*BytesPerWord min: (self lastPointerOf: oop).
hdrType := self headerType: oop.
hdrType = 2 ifTrue: [lastPtr := 0].
prevVal := 0.
+ (self headerStart: oop) to: lastPtr by: self wordSize do:
- (self headerStart: oop) to: lastPtr by: BytesPerWord do:
[:a | val := self longAt: oop+a.
(a > 0 and: [(val = prevVal) & (a ~= lastPtr)])
ifTrue:
+ [prevVal = (self longAt: oop+a-(self wordSize*2)) ifFalse: [strm cr; nextPutAll: ' ...etc...']]
- [prevVal = (self longAt: oop+a-(BytesPerWord*2)) ifFalse: [strm cr; nextPutAll: ' ...etc...']]
ifFalse:
[strm cr; nextPutAll: (a<16 ifTrue: [' ', a hex] ifFalse: [a hex]);
space; space; space; nextPutAll: val hex8; space; space.
+ a = (self wordSize*2) negated ifTrue:
- a = (BytesPerWord*2) negated ifTrue:
[strm nextPutAll: 'size = ' , (val - hdrType) hex].
+ a = self wordSize negated ifTrue:
- a = BytesPerWord negated ifTrue:
[strm nextPutAll: '<' , (self nameOfClass: (val - hdrType)) , '>'].
a = 0 ifTrue: [strm cr; tab; nextPutAll: (self dumpHeader: val)].
a > 0 ifTrue: [strm nextPutAll: (self shortPrint: val)].
+ a = self wordSize ifTrue:
- a = BytesPerWord ifTrue:
[(self isCompiledMethod: oop) ifTrue:
[strm cr; tab; nextPutAll: (self dumpMethodHeader: val)]]].
prevVal := val].
+ lastLong := 256 min: (self sizeBitsOf: oop) - self baseHeaderSize.
- lastLong := 256 min: (self sizeBitsOf: oop) - BaseHeaderSize.
hdrType = 2
ifTrue:
["free" strm cr; nextPutAll: (oop+(self longAt: oop)-2) hex;
space; space; nextPutAll: (oop+(self longAt: oop)-2) printString]
ifFalse:
[(self formatOf: oop) = 3
ifTrue:
[strm cr; tab; nextPutAll: '/ next 3 fields are above SP... /'.
+ lastPtr+self wordSize to: lastPtr+(3*self wordSize) by: self wordSize do:
- lastPtr+BytesPerWord to: lastPtr+(3*BytesPerWord) by: BytesPerWord do:
[:a | val := self longAt: oop+a.
strm cr; nextPutAll: a hex;
space; space; space; nextPutAll: val hex8; space; space.
(self validOop: val) ifTrue: [strm nextPutAll: (self shortPrint: val)]]]
ifFalse:
+ [lastPtr+self wordSize to: lastLong by: self wordSize do:
- [lastPtr+BytesPerWord to: lastLong by: BytesPerWord do:
[:a | val := self longAt: oop+a.
strm cr; nextPutAll: (a<16 ifTrue: [' ', a hex] ifFalse: [a hex]);
space; space; space.
strm nextPutAll: val hex8; space; space;
nextPutAll: (self charsOfLong: val)]]].
]!
Item was changed:
----- Method: NewspeakInterpreterSimulator>>nameOfClass: (in category 'debug support') -----
nameOfClass: classOop
+ (self sizeBitsOf: classOop) = (Metaclass instSize +1*self wordSize) ifTrue:
- (self sizeBitsOf: classOop) = (Metaclass instSize +1*BytesPerWord) ifTrue:
[^ (self nameOfClass:
(self fetchPointer: 5 "thisClass" ofObject: classOop)) , ' class'].
^ self stringOf: (self fetchPointer: 6 "name" ofObject: classOop)!
Item was changed:
----- Method: NewspeakInterpreterSimulator>>printStackTemps:onStream: (in category 'debug support') -----
printStackTemps: ctxt onStream: strm
| home cMethod nArgs nTemps oop |
home := (self fetchClassOf: ctxt) = (self splObj: ClassBlockContext)
ifTrue: [self fetchPointer: HomeIndex ofObject: ctxt]
ifFalse: [ctxt].
cMethod := self fetchPointer: MethodIndex ofObject: home.
nArgs := nTemps := 0.
home = ctxt ifTrue:
[strm cr; tab; nextPutAll: 'args: '.
nArgs := self argumentCountOf: cMethod.
1 to: nArgs do:
[:i | oop := self fetchPointer: TempFrameStart + i-1 ofObject: ctxt.
strm nextPutAll: oop hex; space].
strm cr; tab; nextPutAll: 'temps: '.
nTemps := self tempCountOf: cMethod.
nArgs+1 to: nTemps do:
[:i | oop := self fetchPointer: TempFrameStart + i-1 ofObject: ctxt.
strm nextPutAll: oop hex; space]].
strm cr; tab; nextPutAll: 'stack: '.
+ nTemps + 1 to: (self lastPointerOf: ctxt)//self wordSize - TempFrameStart do:
- nTemps + 1 to: (self lastPointerOf: ctxt)//BytesPerWord - TempFrameStart do:
[:i | oop := self fetchPointer: TempFrameStart + i-1 ofObject: ctxt.
strm nextPutAll: oop hex; space].
!
Item was changed:
----- Method: NewspeakInterpreterSimulator>>printTop: (in category 'debug support') -----
printTop: n
"Print important fields of the top n contexts"
| ctxt classAndSel home top ip sp |
ctxt := activeContext.
^ String streamContents:
[:strm | 1 to: n do:
[:i |
home := (self fetchClassOf: ctxt) = (self splObj: ClassBlockContext)
ifTrue: [self fetchPointer: HomeIndex ofObject: ctxt]
ifFalse: [ctxt].
classAndSel := self
classAndSelectorOfMethod: (self fetchPointer: MethodIndex ofObject: home)
forReceiver: (self fetchPointer: ReceiverIndex ofObject: home).
strm cr; nextPutAll: ctxt hex8.
ctxt = home ifFalse: [strm nextPutAll: ' [] in'].
strm space; nextPutAll: (self nameOfClass: classAndSel first).
strm nextPutAll: '>>'; nextPutAll: (self shortPrint: classAndSel last).
ctxt = activeContext
+ ifTrue: [ip := instructionPointer - method - (self baseHeaderSize - 2).
- ifTrue: [ip := instructionPointer - method - (BaseHeaderSize - 2).
sp := self stackPointerIndex - TempFrameStart + 1.
top := self stackTop]
ifFalse: [ip := self integerValueOf:
(self fetchPointer: InstructionPointerIndex ofObject: ctxt).
sp := self integerValueOf:
(self fetchPointer: StackPointerIndex ofObject: ctxt).
top := self longAt: ctxt + (self lastPointerOf: ctxt)].
strm cr; tab; nextPutAll: 'ip = '; print: ip.
strm cr; tab; nextPutAll: 'sp = '; print: sp.
strm cr; tab; nextPutAll: 'top = '; nextPutAll: (self shortPrint: top).
(ctxt := (self fetchPointer: SenderIndex ofObject: ctxt)) = nilObj
ifTrue: [^strm contents].
].
]!
Item was changed:
----- Method: NewspeakInterpreterSimulator>>shortPrint: (in category 'debug support') -----
shortPrint: oop
| name classOop |
(self isIntegerObject: oop) ifTrue: [^ '=' , (self integerValueOf: oop) printString ,
' (' , (self integerValueOf: oop) hex , ')'].
classOop := self fetchClassOf: oop.
+ (self sizeBitsOf: classOop) = (Metaclass instSize +1*self wordSize) ifTrue: [
- (self sizeBitsOf: classOop) = (Metaclass instSize +1*BytesPerWord) ifTrue: [
^ 'class ' , (self nameOfClass: oop)].
name := self nameOfClass: classOop.
name size = 0 ifTrue: [name := '??'].
name = 'String' ifTrue: [^ (self stringOf: oop) printString].
name = 'ByteString' ifTrue: [^ (self stringOf: oop) printString].
name = 'Symbol' ifTrue: [^ '#' , (self stringOf: oop)].
name = 'ByteSymbol' ifTrue: [^ '#' , (self stringOf: oop)].
name = 'Character' ifTrue: [^ '=' , (Character value: (self integerValueOf:
(self fetchPointer: 0 ofObject: oop))) printString].
name = 'UndefinedObject' ifTrue: [^ 'nil'].
name = 'False' ifTrue: [^ 'false'].
name = 'True' ifTrue: [^ 'true'].
name = 'Float' ifTrue: [^ '=' , (self dbgFloatValueOf: oop) printString].
name = 'Association' ifTrue: [^ '(' ,
+ (self shortPrint: (self longAt: oop + self baseHeaderSize)) ,
- (self shortPrint: (self longAt: oop + BaseHeaderSize)) ,
' -> ' ,
+ (self longAt: oop + self baseHeaderSize + self wordSize) hex8 , ')'].
- (self longAt: oop + BaseHeaderSize + BytesPerWord) hex8 , ')'].
^('AEIOU' includes: name first)
ifTrue: ['an ' , name]
ifFalse: ['a ' , name]!
Item was changed:
----- Method: NewspeakInterpreterSimulator>>stats (in category 'testing') -----
stats
| oop fieldAddr fieldOop last stats v d |
stats := Bag new.
oop := self firstObject.
'Scanning the image...' displayProgressAt: Sensor cursorPoint
from: oop to: endOfMemory
during: [:bar |
[oop < endOfMemory] whileTrue:
[(self isFreeObject: oop) ifFalse:
[stats add: #objects.
fieldAddr := oop + (self lastPointerOf: oop).
[fieldAddr > oop] whileTrue:
[fieldOop := self longAt: fieldAddr.
(self isIntegerObject: fieldOop)
ifTrue: [v := self integerValueOf: fieldOop.
(v between: -16000 and: 16000)
ifTrue: [stats add: #ints32k]
ifFalse: [stats add: #intsOther]]
ifFalse: [fieldOop = nilObj ifTrue: [stats add: #nil]
ifFalse:
[d := fieldOop - oop.
(d between: -16000 and: 16000)
ifTrue: [stats add: #oops32k]
ifFalse: [stats add: #oopsOther]]].
+ fieldAddr := fieldAddr - self wordSize]].
- fieldAddr := fieldAddr - BytesPerWord]].
bar value: oop.
last := oop.
last := last.
oop := self objectAfter: oop]].
^ stats sortedElements!
Item was changed:
----- Method: NewspeakInterpreterSimulator>>stringOf: (in category 'debug support') -----
stringOf: oop
| size long nLongs chars |
^ String streamContents:
[:strm |
size := 100 min: (self stSizeOf: oop).
+ nLongs := size-1//self wordSize+1.
- nLongs := size-1//BytesPerWord+1.
1 to: nLongs do:
+ [:i | long := self longAt: oop + self baseHeaderSize + (i-1*self wordSize).
- [:i | long := self longAt: oop + BaseHeaderSize + (i-1*BytesPerWord).
chars := self charsOfLong: long.
strm nextPutAll: (i=nLongs
+ ifTrue: [chars copyFrom: 1 to: size-1\\self wordSize+1]
- ifTrue: [chars copyFrom: 1 to: size-1\\BytesPerWord+1]
ifFalse: [chars])]]!
Item was changed:
----- Method: NewspeakInterpreterSimulator>>validateOopsIn: (in category 'testing') -----
validateOopsIn: object
| fieldPtr limit former header |
"for each oop in me see if it is legal"
+ fieldPtr := object + self baseHeaderSize. "first field"
- fieldPtr := object + BaseHeaderSize. "first field"
limit := object + (self lastPointerOf: object). "a good field"
[fieldPtr > limit] whileFalse: [
former := self longAt: fieldPtr.
(self validOop: former) ifFalse: [self error: 'invalid oop in pointers object'].
+ fieldPtr := fieldPtr + self wordSize].
- fieldPtr := fieldPtr + BytesPerWord].
"class"
header := self baseHeader: object.
(header bitAnd: CompactClassMask) = 0 ifTrue: [
former := (self classHeader: object) bitAnd: AllButTypeMask.
(self validOop: former) ifFalse: [self halt]].!
Item was changed:
----- Method: NewspeakInterpreterSimulator>>vmPathGet:Length: (in category 'file primitives') -----
vmPathGet: stringBase Length: stringSize
| pathName stringOop |
pathName := Smalltalk vmPath.
+ stringOop := stringBase - self baseHeaderSize. "Due to C call in Interp"
- stringOop := stringBase - BaseHeaderSize. "Due to C call in Interp"
1 to: stringSize do:
[:i | self storeByte: i-1 ofObject: stringOop
withValue: (pathName at: i) asciiValue].
!
Item was changed:
----- Method: NewspeakInterpreterSimulator>>writeImageFileIO: (in category 'image save/restore') -----
writeImageFileIO: numberOfBytesToWrite
"Actually emit the first numberOfBytesToWrite object memory bytes onto the snapshot."
| headerSize file |
+ self wordSize = 4 ifFalse: [self error: 'Not rewritten for 64 bits yet'].
- BytesPerWord = 4 ifFalse: [self error: 'Not rewritten for 64 bits yet'].
headerSize := 64.
[
file := FileStream fileNamed: imageName.
file == nil ifTrue:
[self primitiveFail.
^nil].
file binary.
{
self imageFormatVersion.
headerSize.
numberOfBytesToWrite.
self startOfMemory.
specialObjectsOop.
lastHash.
self ioScreenSize.
fullScreenFlag.
extraVMMemory
}
do: [:long | self putLong: long toFile: file].
"Pad the rest of the header."
7 timesRepeat: [self putLong: 0 toFile: file].
"Position the file after the header."
file position: headerSize.
"Write the object memory."
1
to: numberOfBytesToWrite // 4
do: [:index |
self
putLong: (memory at: index)
toFile: file].
self success: true
]
ensure: [file ifNotNil: [file close]]!
Item was changed:
----- Method: NewspeakInterpreterSimulatorLSB>>nextLongFrom: (in category 'initialization') -----
nextLongFrom: aStream
"Read a 32- or 64-bit quantity from the given (binary) stream."
+ ^ aStream nextLittleEndianNumber: self wordSize!
- ^ aStream nextLittleEndianNumber: BytesPerWord!
Item was changed:
----- Method: NewspeakInterpreterSimulatorMSB>>byteAt: (in category 'memory access') -----
byteAt: byteAddress
| lowBits bpwMinus1 |
+ bpwMinus1 := self wordSize-1.
- bpwMinus1 := BytesPerWord-1.
lowBits := byteAddress bitAnd: bpwMinus1.
^ ((self longAt: byteAddress - lowBits)
bitShift: (lowBits - bpwMinus1) * 8)
bitAnd: 16rFF!
Item was changed:
----- Method: NewspeakInterpreterSimulatorMSB>>byteAt:put: (in category 'memory access') -----
byteAt: byteAddress put: byte
| longWord shift lowBits bpwMinus1 longAddress |
+ bpwMinus1 := self wordSize-1.
- bpwMinus1 := BytesPerWord-1.
lowBits := byteAddress bitAnd: bpwMinus1.
longAddress := byteAddress - lowBits.
longWord := self longAt: longAddress.
shift := (bpwMinus1 - lowBits) * 8.
longWord := longWord
- (longWord bitAnd: (16rFF bitShift: shift))
+ (byte bitShift: shift).
self longAt: longAddress put: longWord.
^byte!
Item was changed:
----- Method: NewspeakInterpreterSimulatorMSB>>charsOfLong: (in category 'debug support') -----
charsOfLong: long
+ ^ (self wordSize to: 1 by: -1) collect:
- ^ (BytesPerWord to: 1 by: -1) collect:
[:i | ((long digitAt: i) between: 14 and: 126)
ifTrue: [(long digitAt: i) asCharacter]
ifFalse: [$?]]!
Item was changed:
----- Method: NewspeakInterpreterSimulatorMSB>>nextLongFrom: (in category 'initialization') -----
nextLongFrom: aStream
"Read a 32- or 64-bit quantity from the given (binary) stream."
+ ^ aStream nextNumber: self wordSize!
- ^ aStream nextNumber: BytesPerWord!
Item was changed:
----- Method: NewspeakInterpreterSimulatorMSB>>shortAt: (in category 'memory access') -----
shortAt: byteAddress
"Return the half-word at byteAddress which must be even."
| lowBits bpwMinus2 |
+ bpwMinus2 := self wordSize-2.
- bpwMinus2 := BytesPerWord-2.
lowBits := byteAddress bitAnd: bpwMinus2.
^ ((self longAt: byteAddress - lowBits)
bitShift: (lowBits - bpwMinus2) * 8)
bitAnd: 16rFFFF
!
Item was changed:
----- Method: NewspeakInterpreterSimulatorMSB>>shortAt:put: (in category 'memory access') -----
shortAt: byteAddress put: a16BitValue
"Return the half-word at byteAddress which must be even."
| longWord shift lowBits bpwMinus2 longAddress |
+ bpwMinus2 := self wordSize-2.
- bpwMinus2 := BytesPerWord-2.
lowBits := byteAddress bitAnd: bpwMinus2.
longAddress := byteAddress - lowBits.
longWord := self longAt: longAddress.
shift := (bpwMinus2 - lowBits) * 8.
longWord := longWord
- (longWord bitAnd: (16rFFFF bitShift: shift))
+ (a16BitValue bitShift: shift).
self longAt: longAddress put: longWord
!
Item was removed:
- ----- Method: NewsqueakIA32ABIPlugin class>>initialize (in category 'class initialization') -----
- initialize
- BytesPerOop := BytesPerWord!
Item was changed:
----- Method: NewsqueakIA32ABIPlugin>>primAddressField (in category 'primitives-accessing') -----
primAddressField
"Answer the unsigned 32-bit integer comprising the address field (the second 32-bit field)."
"<Alien> primAddressField ^<Integer>
<primitive: 'primAddressField' error: errorCode module: 'IA32ABI'>"
| rcvr value valueOop |
<export: true>
rcvr := interpreterProxy stackValue: 0.
+ value := self longAt: rcvr + interpreterProxy baseHeaderSize + interpreterProxy bytesPerOop.
- value := self longAt: rcvr + BaseHeaderSize + BytesPerOop.
valueOop := interpreterProxy positive32BitIntegerFor: value.
^interpreterProxy methodReturnValue: valueOop!
Item was changed:
----- Method: NewsqueakIA32ABIPlugin>>primAddressFieldPut (in category 'primitives-accessing') -----
primAddressFieldPut
"Store an unsigned integer into the size field (the second 32 bit field; little endian)."
"<Alien> addressFieldPut: value <Integer> ^<Integer>
<primitive: 'primAddressFieldPut' error: errorCode module: 'IA32ABI'>"
| rcvr value valueOop |
<export: true>
valueOop := interpreterProxy stackValue: 0.
rcvr := interpreterProxy stackValue: 1.
value := interpreterProxy positive32BitValueOf: valueOop.
interpreterProxy failed ifTrue:
[^interpreterProxy primitiveFailFor: PrimErrBadArgument].
(interpreterProxy isOopImmutable: rcvr) ifTrue:
[^interpreterProxy primitiveFailFor: PrimErrNoModification].
+ self longAt: rcvr + interpreterProxy baseHeaderSize + interpreterProxy bytesPerOop put: value.
- self longAt: rcvr + BaseHeaderSize + BytesPerOop put: value.
^interpreterProxy methodReturnValue: valueOop!
Item was changed:
----- Method: NewsqueakIA32ABIPlugin>>primSizeField (in category 'primitives-accessing') -----
primSizeField
"Answer the signed 32-bit integer comprising the size field (the first 32-bit field)."
"<Alien> primSizeField ^<Integer>
<primitive: 'primSizeField' error: errorCode module: 'IA32ABI'>"
| rcvr value valueOop |
<export: true>
rcvr := interpreterProxy stackValue: 0.
+ value := (self longAt: rcvr + interpreterProxy baseHeaderSize) signedIntFromLong.
- value := (self longAt: rcvr + BaseHeaderSize) signedIntFromLong.
valueOop := interpreterProxy signed32BitIntegerFor: value.
^interpreterProxy methodReturnValue: valueOop!
Item was changed:
----- Method: NewsqueakIA32ABIPlugin>>primSizeFieldPut (in category 'primitives-accessing') -----
primSizeFieldPut
"Store a signed integer into the size field (the first 32 bit field; little endian)."
"<Alien> sizeFieldPut: value <Integer> ^<Integer>
<primitive: 'primSizeFieldPut' error: errorCode module: 'IA32ABI'>"
| rcvr value valueOop |
<export: true>
valueOop := interpreterProxy stackValue: 0.
rcvr := interpreterProxy stackValue: 1.
value := interpreterProxy signed32BitValueOf: valueOop.
interpreterProxy failed ifTrue:
[^interpreterProxy primitiveFailFor: PrimErrBadArgument].
(interpreterProxy isOopImmutable: rcvr) ifTrue:
[^interpreterProxy primitiveFailFor: PrimErrNoModification].
+ self longAt: rcvr + interpreterProxy baseHeaderSize put: value signedIntToLong.
- self longAt: rcvr + BaseHeaderSize put: value signedIntToLong.
^interpreterProxy methodReturnValue: valueOop!
Item was changed:
----- Method: NewsqueakIA32ABIPlugin>>sizeField: (in category 'private-support') -----
sizeField: rcvr
"Answer the first field of rcvr which is assumed to be an Alien of at least 8 bytes"
<inline: true>
+ ^self longAt: rcvr + interpreterProxy baseHeaderSize!
- ^self longAt: rcvr + BaseHeaderSize!
Item was changed:
----- Method: NewsqueakIA32ABIPlugin>>startOfByteData: (in category 'private-support') -----
startOfByteData: rcvr "<byte indexable oop> ^<Integer>"
"Answer the start of rcvr's data, given that it is not an alien."
<inline: true>
+ ^rcvr + interpreterProxy baseHeaderSize!
- ^rcvr + BaseHeaderSize!
Item was changed:
----- Method: NewsqueakIA32ABIPlugin>>startOfData: (in category 'private-support') -----
startOfData: rcvr "<Alien oop> ^<Integer>"
"Answer the start of rcvr's data. For direct aliens this is the address of
the second field. For indirect and pointer aliens it is what the second field points to."
<inline: true>
^(self sizeField: rcvr) > 0
+ ifTrue: [rcvr + interpreterProxy baseHeaderSize + interpreterProxy bytesPerOop]
+ ifFalse: [self longAt: rcvr + interpreterProxy baseHeaderSize + interpreterProxy bytesPerOop]!
- ifTrue: [rcvr + BaseHeaderSize + BytesPerOop]
- ifFalse: [self longAt: rcvr + BaseHeaderSize + BytesPerOop]!
Item was changed:
----- Method: NewsqueakIA32ABIPlugin>>startOfData:withSize: (in category 'private-support') -----
startOfData: rcvr "<Alien oop>" withSize: sizeField "<Integer> ^<Integer>"
"Answer the start of rcvr's data. For direct aliens this is the address of
the second field. For indirect and pointer aliens it is what the second field points to."
<inline: true>
^sizeField > 0
+ ifTrue: [rcvr + interpreterProxy baseHeaderSize + interpreterProxy bytesPerOop]
+ ifFalse: [self longAt: rcvr + interpreterProxy baseHeaderSize + interpreterProxy bytesPerOop]!
- ifTrue: [rcvr + BaseHeaderSize + BytesPerOop]
- ifFalse: [self longAt: rcvr + BaseHeaderSize + BytesPerOop]!
Item was changed:
----- Method: NewsqueakIA32ABIPluginAttic>>primBoxedCalloc (in category 'primitives-memory management') -----
primBoxedCalloc
"This version boxes the result."
"calloc (malloc + zero-fill) arg bytes."
"primBoxedCalloc: byteSize <Integer>
<primitive: 'primBoxedCalloc' module: 'IA32ABI'>"
| byteSize addr oop ptr |
<export: true>
<inline: false>
<var: #ptr type: 'long *'>
<var: #byteSize type: 'long'>
byteSize := interpreterProxy stackIntegerValue: 0.
(interpreterProxy failed
or: [byteSize <= 0 "some mallocs can't deal with malloc(0) bytes"]) ifTrue:
[^interpreterProxy primitiveFailFor: PrimErrBadArgument].
self cCode: 'addr = (sqInt)calloc(1,byteSize)'
inSmalltalk: [addr := self Ccalloc: byteSize].
addr = 0 ifTrue:
[^interpreterProxy primitiveFailFor: PrimErrNoCMemory].
oop := interpreterProxy
instantiateClass: interpreterProxy classAlien
+ indexableSize: 2 * interpreterProxy bytesPerOop.
- indexableSize: 2 * BytesPerOop.
interpreterProxy failed ifTrue:
[^interpreterProxy primitiveFailFor: PrimErrNoMemory].
ptr := interpreterProxy firstIndexableField: oop.
ptr at: 0 put: 0 - byteSize. "indirect args indicated by negative size. Slang doesn't grok negated"
ptr at: 1 put: addr.
interpreterProxy pop: 2 thenPush: oop.
!
Item was changed:
----- Method: NewsqueakIA32ABIPluginAttic>>primBoxedMalloc (in category 'primitives-memory management') -----
primBoxedMalloc
"This version boxes the result."
"Malloc arg bytes."
"primBoxedMalloc: byteSize <Integer>
<primitive: 'primBoxedMalloc' module: 'IA32ABI'>"
| byteSize addr oop ptr |
<export: true>
<inline: false>
<var: #ptr type: 'long *'>
<var: #byteSize type: 'long'>
byteSize := interpreterProxy stackIntegerValue: 0.
(interpreterProxy failed
or: [byteSize <= 0 "some mallocs can't deal with malloc(0) bytes"]) ifTrue:
[^interpreterProxy primitiveFailFor: PrimErrBadArgument].
self cCode: 'addr = (sqInt)malloc(byteSize)'
inSmalltalk: [addr := self Cmalloc: byteSize].
addr = 0 ifTrue:
[^interpreterProxy primitiveFailFor: PrimErrNoCMemory].
oop := interpreterProxy
instantiateClass: interpreterProxy classAlien
+ indexableSize: 2 * interpreterProxy bytesPerOop.
- indexableSize: 2 * BytesPerOop.
interpreterProxy failed ifTrue:
[^interpreterProxy primitiveFailFor: PrimErrNoMemory].
ptr := interpreterProxy firstIndexableField: oop.
ptr at: 0 put: 0 - byteSize. "indirect args indicated by negative size. Slang doesn't grok negated"
ptr at: 1 put: addr.
interpreterProxy pop: 2 thenPush: oop.
!
Item was changed:
----- Method: ObjectMemory class>>initBytesPerWord: (in category 'initialization') -----
initBytesPerWord: nBytes
BytesPerWord := nBytes.
- ShiftForWord := (BytesPerWord log: 2) rounded.
"The following is necessary to avoid confusing the compiler with shifts that are larger than the width of the type on which they operate. In gcc, such shifts cause incorrect code to be generated."
BytesPerWord = 8
ifTrue: "64-bit VM"
[Byte0Mask := 16r00000000000000FF. Byte0Shift := 0.
Byte1Mask := 16r000000000000FF00. Byte1Shift := 8.
Byte2Mask := 16r0000000000FF0000. Byte2Shift := 16.
Byte3Mask := 16r00000000FF000000. Byte3Shift := 24.
Byte4Mask := 16r000000FF00000000. Byte4Shift := 32.
Byte5Mask := 16r0000FF0000000000. Byte5Shift := 40.
Byte6Mask := 16r00FF000000000000. Byte6Shift := 48.
Byte7Mask := 16rFF00000000000000. Byte7Shift := 56.
Bytes3to0Mask := 16r00000000FFFFFFFF.
Bytes7to4Mask := 16rFFFFFFFF00000000]
ifFalse: "32-bit VM"
[Byte0Mask := 16r00000000000000FF. Byte0Shift := 0.
Byte1Mask := 16r000000000000FF00. Byte1Shift := 8.
Byte2Mask := 16r0000000000FF0000. Byte2Shift := 16.
Byte3Mask := 16r00000000FF000000. Byte3Shift := 24.
Byte4Mask := 16r0000000000000000. Byte4Shift := 0. "unused"
Byte5Mask := 16r0000000000000000. Byte5Shift := 0. "unused"
Byte6Mask := 16r0000000000000000. Byte6Shift := 0. "unused"
Byte7Mask := 16r0000000000000000. Byte7Shift := 0. "unused"
Bytes3to0Mask := 16r0000000000000000. "unused"
Bytes7to4Mask := 16r0000000000000000 "unused"].
Byte1ShiftNegated := Byte1Shift negated.
Byte3ShiftNegated := Byte3Shift negated.
Byte4ShiftNegated := Byte4Shift negated.
Byte5ShiftNegated := Byte5Shift negated.
Byte7ShiftNegated := Byte7Shift negated.
"N.B. This is *not* output when generating the interpreter file.
It is left to the various sqConfig.h files to define correctly."
VMBIGENDIAN := Smalltalk endianness == #big!
Item was changed:
----- Method: ObjectMemory>>adjustFieldsAndClassOf:by: (in category 'initialization') -----
adjustFieldsAndClassOf: oop by: offsetBytes
"Adjust all pointers in this object by the given offset."
| fieldAddr fieldOop classHeader newClassOop |
<inline: true>
- <asmLabel: false>
fieldAddr := oop + (self lastPointerOf: oop).
[self oop: fieldAddr isGreaterThan: oop] whileTrue:
[fieldOop := self longAt: fieldAddr.
(self isIntegerObject: fieldOop) ifFalse:
[self longAt: fieldAddr put: fieldOop + offsetBytes].
+ fieldAddr := fieldAddr - self bytesPerOop].
- fieldAddr := fieldAddr - BytesPerOop].
(self headerType: oop) ~= HeaderTypeShort ifTrue:
["adjust class header if not a compact class"
+ classHeader := self longAt: oop - self wordSize.
- classHeader := self longAt: oop - BytesPerWord.
newClassOop := (classHeader bitAnd: AllButTypeMask) + offsetBytes.
+ self longAt: oop - self wordSize put: (newClassOop bitOr: (classHeader bitAnd: TypeMask))]!
- self longAt: oop - BytesPerWord put: (newClassOop bitOr: (classHeader bitAnd: TypeMask))]!
Item was changed:
----- Method: ObjectMemory>>allYoung:and: (in category 'become') -----
allYoung: array1 and: array2
"Return true if all the oops in both arrays, and the arrays
themselves, are in the young object space."
| fieldOffset |
(self oop: array1 isLessThan: youngStart)
ifTrue: [^ false].
(self oop: array2 isLessThan: youngStart)
ifTrue: [^ false].
fieldOffset := self lastPointerOf: array1.
"same size as array2"
+ [fieldOffset >= self baseHeaderSize] whileTrue:
- [fieldOffset >= BaseHeaderSize] whileTrue:
[(self oop: (self longAt: array1 + fieldOffset) isLessThan: youngStart)
ifTrue: [^ false].
((self oop: (self longAt: array2 + fieldOffset) isLessThan: youngStart)
and: [self isNonIntegerObject: (self longAt: array2 + fieldOffset)])
ifTrue: [^ false].
+ fieldOffset := fieldOffset - self wordSize].
- fieldOffset := fieldOffset - BytesPerWord].
^ true!
Item was changed:
----- Method: ObjectMemory>>allocate:headerSize:h1:h2:h3:doFill:format: (in category 'allocation') -----
allocate: byteSize headerSize: hdrSize h1: baseHeader h2: classOop h3: extendedSize doFill: doFill format: format
"Allocate a new object of the given size and number of header words. (Note: byteSize already includes space for the base header word.) Initialize the header fields of the new object and fill the remainder of the object with a value appropriate for the format.
May cause a GC"
| newObj remappedClassOop |
<inline: true>
<var: #i type: 'usqInt'>
<var: #end type: 'usqInt'>
"remap classOop in case GC happens during allocation"
hdrSize > 1 ifTrue: [self pushRemappableOop: classOop].
+ newObj := self allocateChunk: byteSize + (hdrSize - 1 * self wordSize).
- newObj := self allocateChunk: byteSize + (hdrSize - 1 * BytesPerWord).
hdrSize > 1 ifTrue: [remappedClassOop := self popRemappableOop].
hdrSize = 3
ifTrue: [self longAt: newObj put: (extendedSize bitOr: HeaderTypeSizeAndClass).
+ self longAt: newObj + self wordSize put: (remappedClassOop bitOr: HeaderTypeSizeAndClass).
+ self longAt: newObj + (self wordSize*2) put: (baseHeader bitOr: HeaderTypeSizeAndClass).
+ newObj := newObj + (self wordSize*2)].
- self longAt: newObj + BytesPerWord put: (remappedClassOop bitOr: HeaderTypeSizeAndClass).
- self longAt: newObj + (BytesPerWord*2) put: (baseHeader bitOr: HeaderTypeSizeAndClass).
- newObj := newObj + (BytesPerWord*2)].
hdrSize = 2
ifTrue: [self longAt: newObj put: (remappedClassOop bitOr: HeaderTypeClass).
+ self longAt: newObj + self wordSize put: (baseHeader bitOr: HeaderTypeClass).
+ newObj := newObj + self wordSize].
- self longAt: newObj + BytesPerWord put: (baseHeader bitOr: HeaderTypeClass).
- newObj := newObj + BytesPerWord].
hdrSize = 1
ifTrue: [self longAt: newObj put: (baseHeader bitOr: HeaderTypeShort)].
"clear new object"
doFill ifTrue:
[| fillWord end i |
fillWord := format <= self lastPointerFormat
ifTrue: [nilObj] "if pointers, fill with nil oop"
ifFalse: [0].
end := newObj + byteSize.
+ i := newObj + self wordSize.
- i := newObj + BytesPerWord.
[i < end] whileTrue:
[self longAt: i put: fillWord.
+ i := i + self wordSize]].
- i := i + BytesPerWord]].
DoAssertionChecks
ifTrue: [self okayOop: newObj.
self oopHasOkayClass: newObj.
(self objectAfter: newObj) = freeBlock
ifFalse: [self error: 'allocate bug: did not set header of new oop correctly'].
(self objectAfter: freeBlock) = endOfMemory
ifFalse: [self error: 'allocate bug: did not set header of freeBlock correctly']].
^newObj!
Item was changed:
----- Method: ObjectMemory>>allocateChunk: (in category 'allocation') -----
allocateChunk: byteSize
"Allocate a chunk of the given size. Sender must be sure that the requested size includes enough space for the header word(s). "
"Details: To limit the time per incremental GC, do one every so many allocations. The number is settable via primitiveVMParameter to tune your memory system"
| enoughSpace newFreeSize newChunk |
<inline: true>
allocationCount >= allocationsBetweenGCs
ifTrue: ["do an incremental GC every so many allocations to keep pauses short"
self incrementalGC].
enoughSpace := self sufficientSpaceToAllocate: byteSize.
enoughSpace
ifFalse: ["signal that space is running low, but proceed with allocation if possible"
signalLowSpace := true.
lowSpaceThreshold := 0. "disable additional interrupts until lowSpaceThreshold is reset by image"
self saveProcessSignalingLowSpace.
self forceInterruptCheck].
+ (self oop: (self sizeOfFree: freeBlock) isLessThan: byteSize + self baseHeaderSize)
- (self oop: (self sizeOfFree: freeBlock) isLessThan: byteSize + BaseHeaderSize)
ifTrue: [self error: 'out of memory'].
"if we get here, there is enough space for allocation to succeed "
newFreeSize := (self sizeOfFree: freeBlock) - byteSize.
newChunk := freeBlock.
freeBlock := freeBlock + byteSize.
"Assume: client will initialize object header of free chunk, so following is not needed:"
"self setSizeOfFree: newChunk to: byteSize."
self setSizeOfFree: freeBlock to: newFreeSize.
allocationCount := allocationCount + 1.
^newChunk!
Item was changed:
----- Method: ObjectMemory>>allocationUnit (in category 'allocation') -----
allocationUnit
+ ^self wordSize!
- ^BytesPerWord!
Item was changed:
----- Method: ObjectMemory>>badContextSize: (in category 'contexts') -----
badContextSize: oop
+ | numSlots |
+ numSlots := self numSlotsOf: oop.
+ ^numSlots ~= SmallContextSlots and: [numSlots ~= LargeContextSlots]!
- ^(self numBytesOf: oop) ~= (SmallContextSize-BaseHeaderSize)
- and: [(self numBytesOf: oop) ~= (LargeContextSize-BaseHeaderSize)]!
Item was changed:
----- Method: ObjectMemory>>baseHeaderSize (in category 'interpreter access') -----
baseHeaderSize
+ "To support SmartSyntaxPluginCodeGenerator"
+ ^self baseHeaderSize!
- ^BaseHeaderSize!
Item was changed:
----- Method: ObjectMemory>>beRootWhileForwarding: (in category 'gc -- compaction') -----
beRootWhileForwarding: oop
"Record that the given oop in the old object area points to an object in the young area when oop may be forwarded."
"Warning: No young objects should be recorded as roots. Callers are responsible for ensuring this constraint is not violated."
<inline: false> "for debugging..."
| header fwdBlock headerLoc |
"If labelled, gcc duplicates the label when inlining updatePointersInRangeFrom:to:"
- <asmLabel: false>
header := self longAt: oop.
(header bitAnd: MarkBit) ~= 0
ifTrue: "This oop is forwarded"
[fwdBlock := (header bitAnd: AllButMarkBitAndTypeMask) << 1.
self assert: (self fwdBlockValid: fwdBlock).
+ headerLoc := fwdBlock + self wordSize]
- headerLoc := fwdBlock + BytesPerWord]
ifFalse: "Normal -- no forwarding"
[headerLoc := oop].
"use headerLoc var to eliminate duplication on inlining noteAsRoot:headerLoc:
older versions of this method had two separate sends of noteAsRoot:headerLoc:"
self noteAsRoot: oop headerLoc: headerLoc!
Item was changed:
----- Method: ObjectMemory>>byteSwapByteObjectsFrom:to:flipFloatsIf: (in category 'image segment in/out') -----
byteSwapByteObjectsFrom: startOop to: stopAddr flipFloatsIf: flipFloatWords
"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. For Floats
swap their most and least significant words if required."
| oop fmt temp wordAddr |
oop := startOop.
[self oop: oop isLessThan: stopAddr] whileTrue:
[(self isFreeObject: oop) ifFalse:
[fmt := self formatOf: oop.
fmt >= self firstByteFormat ifTrue:
["oop contains bytes; unswap"
+ wordAddr := oop + self baseHeaderSize.
- wordAddr := oop + BaseHeaderSize.
fmt >= self firstCompiledMethodFormat ifTrue: "compiled method; start after methodHeader and literals"
+ [wordAddr := wordAddr + ((self literalCountOf: oop) + LiteralStart * self bytesPerOop)].
- [wordAddr := wordAddr + ((self literalCountOf: oop) + LiteralStart * BytesPerOop)].
self reverseBytesFrom: wordAddr to: oop + (self sizeBitsOf: oop)].
fmt = self firstLongFormat ifTrue: "Bitmap, Float etc"
[(self compactClassIndexOf: oop) = ClassFloatCompactIndex
ifTrue:
[flipFloatWords 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 + BaseHeaderSize.
- self longAt: oop + BaseHeaderSize put: (self longAt: oop + BaseHeaderSize + 4).
- self longAt: oop + BaseHeaderSize + 4 put: temp]]
ifFalse:
+ [self wordSize = 8 ifTrue:
- [BytesPerWord = 8 ifTrue:
["Object contains 32-bit half-words packed into 64-bit machine words."
+ wordAddr := oop + self baseHeaderSize.
- wordAddr := oop + BaseHeaderSize.
self reverseWordsFrom: wordAddr to: oop + (self sizeBitsOf: oop)]]]].
oop := self objectAfter: oop]!
Item was changed:
----- Method: ObjectMemory>>byteSwapped: (in category 'image save/restore') -----
byteSwapped: w
"Answer the given integer with its bytes in the reverse order."
<api>
<returnTypeC: #sqInt>
+ self cppIf: self wordSize = 4
- self cppIf: BytesPerWord = 4
ifTrue:
[^ ((w bitShift: Byte3ShiftNegated) bitAnd: Byte0Mask)
+ ((w bitShift: Byte1ShiftNegated) bitAnd: Byte1Mask)
+ ((w bitShift: Byte1Shift ) bitAnd: Byte2Mask)
+ ((w bitShift: Byte3Shift ) bitAnd: Byte3Mask)]
ifFalse:
[^ ((w bitShift: Byte7ShiftNegated) bitAnd: Byte0Mask)
+ ((w bitShift: Byte5ShiftNegated) bitAnd: Byte1Mask)
+ ((w bitShift: Byte3ShiftNegated) bitAnd: Byte2Mask)
+ ((w bitShift: Byte1ShiftNegated) bitAnd: Byte3Mask)
+ ((w bitShift: Byte1Shift ) bitAnd: Byte4Mask)
+ ((w bitShift: Byte3Shift ) bitAnd: Byte5Mask)
+ ((w bitShift: Byte5Shift ) bitAnd: Byte6Mask)
+ ((w bitShift: Byte7Shift ) bitAnd: Byte7Mask)]!
Item was added:
+ ----- Method: ObjectMemory>>bytesPerOop (in category 'accessing') -----
+ bytesPerOop
+ "N.B. This would appear to hard-code the header size for 32-bit images. But if generating
+ a 64-bit image, this method could be removed and the relevant one substituted. We can't
+ mark this method as <doNotGenerate> as we need an actual method to guide code gen."
+ ^4!
Item was changed:
----- Method: ObjectMemory>>changeClassOf:to: (in category 'interpreter access') -----
changeClassOf: rcvr to: argClass
"Attempt to change the class of the receiver to the argument given that the
format of the receiver matches the format of the argument. If successful,
answer 0, otherwise answer an error code indicating the reason for failure.
Fail if the receiver is an instance of a compact class and the argument isn't,
or if the format of the receiver is incompatible with the format of the argument,
or if the argument is a fixed class and the receiver's size differs from the size
that an instance of the argument should have."
| classHdr sizeHiBits argClassInstByteSize argFormat rcvrFormat rcvrHdr ccIndex |
"Check what the format of the class says"
classHdr := self formatOfClass: argClass. "Low 2 bits are 0"
"Compute the size of instances of the class (used for fixed field classes only)"
sizeHiBits := (classHdr bitAnd: 16r60000) >> 9.
classHdr := classHdr bitAnd: 16r1FFFF.
argClassInstByteSize := (classHdr bitAnd: SizeMask) + sizeHiBits. "size in bytes -- low 2 bits are 0"
"Check the receiver's format against that of the class"
argFormat := self formatOfHeader: classHdr.
rcvrHdr := self baseHeader: rcvr.
rcvrFormat := self formatOfHeader: rcvrHdr.
"If the receiver is a byte object we need to clear the number of odd bytes from the format."
rcvrFormat > self firstByteFormat ifTrue:
[rcvrFormat := rcvrFormat bitAnd: 16rC].
argFormat = rcvrFormat ifFalse:
[^PrimErrInappropriate]. "no way"
"For fixed field classes, the sizes must match.
Note: argClassInstByteSize-4 because base header is included in class size."
argFormat < self arrayFormat
ifTrue:
+ [(argClassInstByteSize - self baseHeaderSize) ~= (self numBytesOf: rcvr) ifTrue:
- [(argClassInstByteSize - BaseHeaderSize) ~= (self numBytesOf: rcvr) ifTrue:
[^PrimErrBadReceiver]]
ifFalse:
[argFormat = self indexablePointersFormat ifTrue: "For indexable plus fixed fields the receiver must be at least big enough."
+ [(argClassInstByteSize - self baseHeaderSize) > (self numBytesOf: rcvr) ifTrue:
- [(argClassInstByteSize - BaseHeaderSize) > (self numBytesOf: rcvr) ifTrue:
[^PrimErrBadReceiver]]].
(self headerTypeOfHeader: rcvrHdr) = HeaderTypeShort
ifTrue: "Compact classes. Check if the arg's class is compact and exchange ccIndex"
[ccIndex := classHdr bitAnd: CompactClassMask.
ccIndex = 0 ifTrue:
[^PrimErrInappropriate]. "class is not compact"
self cppIf: IMMUTABILITY
ifTrue: [(rcvrHdr bitAnd: ImmutabilityBit) ~= 0 ifTrue:
[^PrimErrNoModification]].
self baseHeader: rcvr put: ((rcvrHdr bitClear: CompactClassMask) bitOr: ccIndex)]
ifFalse: "Exchange the class pointer, which could make rcvr a root for argClass"
[self cppIf: IMMUTABILITY
ifTrue: [(rcvrHdr bitAnd: ImmutabilityBit) ~= 0 ifTrue:
[^PrimErrNoModification]].
"N.B. the recursive scan-mark algorithm uses the header word's size and compact class
fields to determine the header type when it reuses the header type bits for the mark
state. So it is alas an invariant that non-compact headers have a 0 compact class field."
(self compactClassIndexOfHeader: rcvrHdr) ~= 0 ifTrue:
[self baseHeader: rcvr put: (rcvrHdr bitClear: CompactClassMask)].
+ self longAt: rcvr - self baseHeaderSize put: (argClass bitOr: (self headerTypeOfHeader: rcvrHdr)).
- self longAt: rcvr - BaseHeaderSize put: (argClass bitOr: (self headerTypeOfHeader: rcvrHdr)).
(self oop: rcvr isLessThan: youngStart) ifTrue:
[self possibleRootStoreInto: rcvr value: argClass]].
"ok"
^0!
Item was changed:
----- Method: ObjectMemory>>checkHeapIntegrity (in category 'memory access') -----
checkHeapIntegrity
"Perform an integrity/leak check using the heapMap. Assume
clearLeakMapAndMapAccessibleObjects has set a bit at each
object's header. Scan all objects in the heap checking that every
pointer points to a header. Scan the rootTable, remapBuffer and
extraRootTable checking that every entry is a pointer to a header.
Check that the number of roots is correct and that all rootTable
entries have their rootBit set. Answer if all checks pass."
| ok obj sz hdr fmt fi fieldOop numRootsInHeap |
<inline: false>
ok := true.
numRootsInHeap := 0.
obj := self firstObject.
[self oop: obj isLessThan: self startOfFreeSpace] whileTrue:
[(self isFreeObject: obj)
ifTrue:
[sz := self sizeOfFree: obj]
ifFalse:
[hdr := self baseHeader: obj.
(self isYoungRootHeader: hdr) ifTrue:
[numRootsInHeap := numRootsInHeap + 1].
(self compactClassIndexOfHeader: hdr) = 0 ifTrue:
[fieldOop := (self classHeader: obj) bitAnd: AllButTypeMask.
((self isIntegerObject: fieldOop)
or: [(self heapMapAtWord: (self pointerForOop: fieldOop)) = 0]) ifTrue:
[self print: 'object leak in '; printHex: obj; print: ' class = '; printHex: fieldOop; cr.
ok := false]].
fmt := self formatOfHeader: hdr.
(fmt <= self lastPointerFormat or: [fmt >= self firstCompiledMethodFormat]) ifTrue:
[fmt >= self firstCompiledMethodFormat
ifTrue: [fi := (self literalCountOf: obj) + LiteralStart]
ifFalse: [(fmt = self indexablePointersFormat and: [self isContextHeader: hdr])
ifTrue: [fi := CtxtTempFrameStart + (self fetchStackPointerOf: obj)]
ifFalse: [fi := self lengthOf: obj]].
[(fi := fi - 1) >= 0] whileTrue:
[fieldOop := self fetchPointer: fi ofObject: obj.
(self isNonIntegerObject: fieldOop) ifTrue:
+ [(fieldOop bitAnd: self wordSize - 1) ~= 0
- [(fieldOop bitAnd: BytesPerWord - 1) ~= 0
ifTrue:
[self print: 'misaligned oop in '; printHex: obj; print: ' @ '; printNum: fi; print: ' = '; printHex: fieldOop; cr.
ok := false]
ifFalse:
[(self heapMapAtWord: (self pointerForOop: fieldOop)) = 0 ifTrue:
[self print: 'object leak in '; printHex: obj; print: ' @ '; printNum: fi; print: ' = '; printHex: fieldOop; cr.
ok := false]]]]].
sz := self sizeBitsOf: obj].
obj := self oopFromChunk: obj + sz].
numRootsInHeap ~= rootTableCount ifTrue:
[self print: 'root count mismatch. #heap roots '; printNum: numRootsInHeap; print: '; #roots '; printNum: rootTableCount; cr.
"But the system copes with overflow..."
ok := rootTableOverflowed and: [allocationCount > allocationsBetweenGCs]].
1 to: rootTableCount do:
[:ri|
obj := rootTable at: ri.
+ (obj bitAnd: self wordSize - 1) ~= 0
- (obj bitAnd: BytesPerWord - 1) ~= 0
ifTrue:
[self print: 'misaligned oop in rootTable @ '; printNum: ri; print: ' = '; printHex: obj; cr.
ok := false]
ifFalse:
[(self heapMapAtWord: (self pointerForOop: obj)) = 0
ifTrue:
[self print: 'object leak in rootTable @ '; printNum: ri; print: ' = '; printHex: obj; cr.
ok := false]
ifFalse:
[hdr := self baseHeader: obj.
(self isYoungRootHeader: hdr) ifFalse:
[self print: 'non-root in rootTable @ '; printNum: ri; print: ' = '; printHex: obj; cr.
ok := false]]]].
1 to: remapBufferCount do:
[:ri|
obj := remapBuffer at: ri.
+ (obj bitAnd: self wordSize - 1) ~= 0
- (obj bitAnd: BytesPerWord - 1) ~= 0
ifTrue:
[self print: 'misaligned remapRoot @ '; printNum: ri; print: ' = '; printHex: obj; cr.
ok := false]
ifFalse:
[(self heapMapAtWord: (self pointerForOop: obj)) = 0
ifTrue:
[self print: 'object leak in remapRoots @ '; printNum: ri; print: ' = '; printHex: obj; cr.
ok := false]]].
1 to: extraRootCount do:
[:ri|
obj := (extraRoots at: ri) at: 0.
+ (obj bitAnd: self wordSize - 1) ~= 0
- (obj bitAnd: BytesPerWord - 1) ~= 0
ifTrue:
[self print: 'misaligned extraRoot @ '; printNum: ri; print: ' => '; printHex: obj; cr.
ok := false]
ifFalse:
[(self heapMapAtWord: (self pointerForOop: obj)) = 0
ifTrue:
[self print: 'object leak in extraRoots @ '; printNum: ri; print: ' => '; printHex: obj; cr.
ok := false]]].
^ok!
Item was changed:
----- Method: ObjectMemory>>checkOkayOop: (in category 'debug support') -----
checkOkayOop: oop
"Verify that the given oop is legitimate. Check address, header, and size but not class.
Answer true if OK. Otherwise print reason and answer false."
<api>
<var: #oop type: #usqInt>
| sz type fmt unusedBit |
"address and size checks"
(self isIntegerObject: oop) ifTrue: [ ^true ].
(oop >= self startOfMemory and: [oop < endOfMemory])
ifFalse: [ self print: 'oop is not a valid address'; cr. ^false ].
+ ((oop \\ self wordSize) = 0)
- ((oop \\ BytesPerWord) = 0)
ifFalse: [ self print: 'oop is not a word-aligned address'; cr. ^false ].
sz := self sizeBitsOf: oop.
(oop + sz) < endOfMemory
ifFalse: [ self print: 'oop size would make it extend beyond the end of memory'; cr. ^false ].
"header type checks"
type := self headerType: oop.
type = HeaderTypeFree
ifTrue: [ self print: 'oop is a free chunk, not an object'; cr. ^false ].
type = HeaderTypeShort ifTrue: [
(self compactClassIndexOf: oop) = 0
ifTrue: [ self print: 'cannot have zero compact class field in a short header'; cr. ^false ].
].
type = HeaderTypeClass ifTrue: [
+ ((oop >= self wordSize) and: [(self headerType: oop - self wordSize) = type])
- ((oop >= BytesPerWord) and: [(self headerType: oop - BytesPerWord) = type])
ifFalse: [ self print: 'class header word has wrong type'; cr. ^false ].
].
type = HeaderTypeSizeAndClass ifTrue: [
+ ((oop >= (self wordSize*2)) and:
+ [(self headerType: oop - (self wordSize*2)) = type and:
+ [(self headerType: oop - self wordSize) = type]])
- ((oop >= (BytesPerWord*2)) and:
- [(self headerType: oop - (BytesPerWord*2)) = type and:
- [(self headerType: oop - BytesPerWord) = type]])
ifFalse: [ self print: 'class header word has wrong type'; cr. ^false ].
].
"format check"
fmt := self formatOf: oop.
((fmt = 5) | (fmt = 7))
ifTrue: [ self print: 'oop has an unknown format type'; cr. ^false ].
"mark and root bit checks"
unusedBit := 16r20000000.
+ self wordSize = 8
- BytesPerWord = 8
ifTrue:
[unusedBit := unusedBit << 16.
unusedBit := unusedBit << 16].
((self longAt: oop) bitAnd: unusedBit) = 0
ifFalse: [ self print: 'unused header bit 30 is set; should be zero'; cr. ^false ].
"xxx
((self longAt: oop) bitAnd: MarkBit) = 0
ifFalse: [ self print: 'mark bit should not be set except during GC' ].
xxx"
((self isYoungRoot: oop) and: [oop >= youngStart])
ifTrue: [ self print: 'root bit is set in a young object'; cr. ^false ].
^true
!
Item was changed:
----- Method: ObjectMemory>>classHeader: (in category 'header access') -----
classHeader: oop
<api>
+ ^self longAt: oop - self baseHeaderSize!
- ^self longAt: oop - BaseHeaderSize!
Item was changed:
----- Method: ObjectMemory>>clone: (in category 'allocation') -----
clone: obj
"Return a shallow copy of the given object. May cause GC"
"Assume: Oop is a real object, not a small integer."
| extraHdrBytes bytes newChunk remappedOop fromIndex toIndex lastFrom newOop header hash |
<inline: false>
<var: #lastFrom type: #usqInt>
<var: #fromIndex type: #usqInt>
self assert: (self isNonIntegerObject: obj).
extraHdrBytes := self extraHeaderBytes: obj.
bytes := self sizeBitsOf: obj.
bytes := bytes + extraHdrBytes.
"allocate space for the copy, remapping obj in case of a GC"
self pushRemappableOop: obj.
"check it is safe to allocate this much memory. Return 0 if not"
(self sufficientSpaceToAllocate: 2500 + bytes) ifFalse:[^0].
newChunk := self allocateChunk: bytes.
remappedOop := self popRemappableOop.
"copy old to new including all header words"
+ toIndex := newChunk - self wordSize. "loop below uses pre-increment"
+ fromIndex := (remappedOop - extraHdrBytes) - self wordSize.
- toIndex := newChunk - BytesPerWord. "loop below uses pre-increment"
- fromIndex := (remappedOop - extraHdrBytes) - BytesPerWord.
lastFrom := fromIndex + bytes.
[fromIndex < lastFrom] whileTrue:
+ [self longAt: (toIndex := toIndex + self wordSize) put: (self longAt: (fromIndex := fromIndex + self wordSize))].
- [self longAt: (toIndex := toIndex + BytesPerWord) put: (self longAt: (fromIndex := fromIndex + BytesPerWord))].
newOop := newChunk + extraHdrBytes. "convert from chunk to oop"
"fix base header: compute new hash and clear Mark and Root bits"
hash := self newObjectHash.
header := (self longAt: newOop) bitAnd: 16r1FFFF.
"use old ccIndex, format, size, and header-type fields"
header := header bitOr: ((hash << HashBitsOffset) bitAnd: HashBits).
self longAt: newOop put: header.
^newOop
!
Item was changed:
----- Method: ObjectMemory>>containOnlyMutableOops:and: (in category 'become') -----
containOnlyMutableOops: array1 and: array2
"Return true if neither array contains an immutable.
You may not be allowed to become: immutables."
| fieldOffset |
fieldOffset := self lastPointerOf: array1.
"same size as array2"
+ [fieldOffset >= self baseHeaderSize] whileTrue:
- [fieldOffset >= BaseHeaderSize] whileTrue:
[(self isOopImmutable: (self longAt: array1 + fieldOffset)) ifTrue: [^false].
(self isOopImmutable: (self longAt: array2 + fieldOffset)) ifTrue: [^false].
+ fieldOffset := fieldOffset - self wordSize].
- fieldOffset := fieldOffset - BytesPerWord].
^true!
Item was changed:
----- Method: ObjectMemory>>containOnlyOops: (in category 'become') -----
containOnlyOops: array
"Answer if the array does not contain a small integer. You
can't become: SmallIntegers!!"
| fieldOffset |
fieldOffset := self lastPointerOf: array.
"same size as array2"
+ [fieldOffset >= self baseHeaderSize] whileTrue:
- [fieldOffset >= BaseHeaderSize] whileTrue:
[(self isIntegerObject: (self longAt: array + fieldOffset)) ifTrue: [^ false].
+ fieldOffset := fieldOffset - self bytesPerOop].
- fieldOffset := fieldOffset - BytesPerOop].
^true!
Item was changed:
----- Method: ObjectMemory>>containOnlyOops:and: (in category 'become') -----
containOnlyOops: array1 and: array2
"Answer if neither array contains a small integer. You
can't become: integers!!"
| fieldOffset |
fieldOffset := self lastPointerOf: array1.
"same size as array2"
+ [fieldOffset >= self baseHeaderSize]
- [fieldOffset >= BaseHeaderSize]
whileTrue: [(self isIntegerObject: (self longAt: array1 + fieldOffset)) ifTrue: [^ false].
(self isIntegerObject: (self longAt: array2 + fieldOffset)) ifTrue: [^ false].
+ fieldOffset := fieldOffset - self bytesPerOop].
- fieldOffset := fieldOffset - BytesPerOop].
^ true!
Item was changed:
----- Method: ObjectMemory>>copyObj:toSegment:addr:stopAt:saveOopAt:headerAt: (in category 'image segment in/out') -----
copyObj: oop toSegment: segmentWordArray addr: lastSeg stopAt: stopAddr saveOopAt: oopPtr headerAt: hdrPtr
"Copy this object into the segment beginning at lastSeg.
Install a forwarding pointer, and save oop and header.
Fail if out of space. Return the next segmentAddr if successful."
"Copy the object..."
| extraSize bodySize hdrAddr |
<inline: false>
self flag: #Dan. "None of the imageSegment stuff has been updated for 64 bits"
extraSize := self extraHeaderBytes: oop.
bodySize := self sizeBitsOf: oop.
(self oop: (lastSeg + extraSize + bodySize) isGreaterThanOrEqualTo: stopAddr) ifTrue:
[^0]. "failure"
+ self transfer: extraSize + bodySize // self wordSize "wordCount"
- self transfer: extraSize + bodySize // BytesPerWord "wordCount"
from: oop - extraSize
+ to: lastSeg+self wordSize.
- to: lastSeg+BytesPerWord.
"Clear root and mark bits of all headers copied into the segment"
+ hdrAddr := lastSeg+self wordSize + extraSize.
- hdrAddr := lastSeg+BytesPerWord + extraSize.
self longAt: hdrAddr put: ((self longAt: hdrAddr) bitAnd: AllButRootBit - MarkBit).
+ self forward: oop to: (lastSeg+self wordSize + extraSize - segmentWordArray)
- self forward: oop to: (lastSeg+BytesPerWord + extraSize - segmentWordArray)
savingOopAt: oopPtr
andHeaderAt: hdrPtr.
"Return new end of segment"
^lastSeg + extraSize + bodySize!
Item was changed:
----- Method: ObjectMemory>>fetchByte:ofObject: (in category 'object access') -----
fetchByte: byteIndex ofObject: oop
<api>
+ ^self byteAt: oop + self baseHeaderSize + byteIndex!
- ^self byteAt: oop + BaseHeaderSize + byteIndex!
Item was changed:
----- Method: ObjectMemory>>fetchClassOf: (in category 'object access') -----
fetchClassOf: oop
| ccIndex |
<inline: true>
- <asmLabel: false>
^(self isIntegerObject: oop)
ifTrue: [self splObj: ClassSmallInteger]
ifFalse:
[(ccIndex := (self compactClassIndexOf: oop)) = 0
ifTrue: [(self classHeader: oop) bitAnd: AllButTypeMask]
ifFalse: [self compactClassAt: ccIndex]]!
Item was changed:
----- Method: ObjectMemory>>fetchClassOfNonImm: (in category 'object access') -----
fetchClassOfNonImm: oop
| ccIndex |
<inline: true>
- <asmLabel: false>
^(ccIndex := (self compactClassIndexOf: oop)) = 0
ifTrue: [(self classHeader: oop) bitAnd: AllButTypeMask]
ifFalse: [self compactClassAt: ccIndex]!
Item was changed:
----- Method: ObjectMemory>>fetchLong32:ofObject: (in category 'object access') -----
fetchLong32: fieldIndex ofObject: oop
" index by 32-bit units, and return a 32-bit value. Intended to replace fetchWord:ofObject:"
+ ^ self long32At: oop + self baseHeaderSize + (fieldIndex << 2)!
- ^ self long32At: oop + BaseHeaderSize + (fieldIndex << 2)!
Item was changed:
----- Method: ObjectMemory>>fetchLong64:ofObject: (in category 'object access') -----
fetchLong64: longIndex ofObject: oop
<returnTypeC: #sqLong>
+ ^self long64At: oop + self baseHeaderSize + (longIndex << 3)!
- ^self long64At: oop + BaseHeaderSize + (longIndex << 3)!
Item was changed:
----- Method: ObjectMemory>>fetchPointer:ofObject: (in category 'object access') -----
fetchPointer: fieldIndex ofObject: oop
"index by word size, and return a pointer as long as the word size"
<api>
+ ^self longAt: oop + self baseHeaderSize + (fieldIndex << self shiftForWord)!
- ^self longAt: oop + BaseHeaderSize + (fieldIndex << ShiftForWord)!
Item was changed:
----- Method: ObjectMemory>>fetchShort16:ofObject: (in category 'object access') -----
fetchShort16: shortIndex ofObject: oop
+ ^self shortAt: oop + self baseHeaderSize + (shortIndex << 1)!
- ^self shortAt: oop + BaseHeaderSize + (shortIndex << 1)!
Item was changed:
----- Method: ObjectMemory>>finalizeReference: (in category 'finalization') -----
finalizeReference: oop
"During sweep phase we have encountered a weak reference. Check if its object
has gone away (or is about to) and if so, signal a semaphore. Do *not* inline
this in sweepPhase - it is quite an unlikely case to run into a weak reference"
| weakOop oopGone chunk numFields firstField lastField |
<inline: false>
<var: #oop type: #usqInt>
<var: #weakOop type: #usqInt>
numFields := self nonWeakFieldsOf: oop. "so nonWeakFieldsOf: may be inlined"
+ firstField := self baseHeaderSize + (numFields << self shiftForWord).
- firstField := BaseHeaderSize + (numFields << ShiftForWord).
lastField := self lastPointerOf: oop.
+ firstField to: lastField by: self wordSize do:
- firstField to: lastField by: BytesPerWord do:
[:i|
weakOop := self longAt: oop + i.
"ar 1/18/2005: Added oop < youngStart test to make sure we're not testing
objects in non-GCable region. This could lead to a forward reference in
old space with the oop pointed to not being marked and thus treated as free."
(weakOop = nilObj or: [(self isIntegerObject: weakOop) or:[weakOop < youngStart]]) ifFalse:
["Check if the object is being collected.
If the weak reference points
* backward: check if the weakOops chunk is free
* forward: check if the weakOoop has been marked by GC"
weakOop < oop
ifTrue: [chunk := self chunkFromOop: weakOop.
oopGone := ((self longAt: chunk) bitAnd: TypeMask) = HeaderTypeFree]
ifFalse: [oopGone := (self isMarked: weakOop) not].
oopGone ifTrue: "Store nil in the pointer and signal the interpreter"
[self longAt: oop + i put: nilObj.
self signalFinalization: oop]]]!
Item was changed:
----- Method: ObjectMemory>>firstFixedField: (in category 'object access') -----
firstFixedField: oop
<returnTypeC: #'void *'>
+ ^ self pointerForOop: oop + self baseHeaderSize!
- ^ self pointerForOop: oop + BaseHeaderSize!
Item was changed:
----- Method: ObjectMemory>>firstIndexableField: (in category 'object format') -----
firstIndexableField: oop
"NOTE: overridden in various simulator subclasses to add coercion to CArray, so please duplicate any changes"
| hdr fmt totalLength fixedFields |
<returnTypeC: #'void *'>
hdr := self baseHeader: oop.
fmt := self formatOfHeader: hdr.
fmt <= self lastPointerFormat ifTrue:
["pointer; may need to delve into the class format word"
totalLength := self lengthOf: oop baseHeader: hdr format: fmt.
fixedFields := self fixedFieldsOf: oop format: fmt length: totalLength.
+ ^self pointerForOop: oop + self baseHeaderSize + (fixedFields << self shiftForWord)].
+ ^self pointerForOop: oop + self baseHeaderSize!
- ^self pointerForOop: oop + BaseHeaderSize + (fixedFields << ShiftForWord)].
- ^self pointerForOop: oop + BaseHeaderSize!
Item was changed:
----- Method: ObjectMemory>>fixedFieldsOf:format:length: (in category 'object format') -----
fixedFieldsOf: oop format: fmt length: wordLength
"
NOTE: This code supports the backward-compatible extension to 8 bits of instSize.
When we revise the image format, it should become...
^ (classFormat >> 2 bitAnd: 16rFF) - 1
"
| class classFormat |
<inline: true>
- <asmLabel: false>
((fmt > self lastPointerFormat) or: [fmt = self arrayFormat]) ifTrue: [^0]. "indexable fields only"
fmt < 2 ifTrue: [^wordLength]. "fixed fields only (zero or more)"
"fmt = 3 or 4: mixture of fixed and indexable fields, so must look at class format word"
class := self fetchClassOfNonImm: oop.
classFormat := self formatOfClass: class.
^(classFormat >> 11 bitAnd: 16rC0) + (classFormat >> 2 bitAnd: 16r3F) - 1!
Item was changed:
----- Method: ObjectMemory>>fwdTableInit: (in category 'gc -- compaction') -----
fwdTableInit: blkSize
"Set the limits for a table of two- or three-word forwarding blocks above the last used oop. The pointer fwdTableNext moves up to fwdTableLast. Used for compaction of memory and become-ing objects. Returns the number of forwarding blocks available."
| |
<inline: false>
"set endOfMemory to just after a minimum-sized free block"
+ self setSizeOfFree: freeBlock to: self baseHeaderSize.
+ self setEndOfMemory: freeBlock + self baseHeaderSize.
- self setSizeOfFree: freeBlock to: BaseHeaderSize.
- self setEndOfMemory: freeBlock + BaseHeaderSize.
"make a fake free chunk at endOfMemory for use as a sentinal in memory scans"
+ self setSizeOfFree: endOfMemory to: self baseHeaderSize.
- self setSizeOfFree: endOfMemory to: BaseHeaderSize.
"use all memory free between freeBlock and memoryLimit for forwarding table"
"Note: Forward blocks must be quadword aligned."
+ fwdTableNext := (endOfMemory + self baseHeaderSize + 7) bitAnd: WordMask-7.
- fwdTableNext := (endOfMemory + BaseHeaderSize + 7) bitAnd: WordMask-7.
self flag: #Dan. "Above line does not do what it says (quadword is 16 or 32 bytes)"
fwdTableLast := memoryLimit - blkSize. "last forwarding table entry"
"return the number of forwarding blocks available"
^ (fwdTableLast - fwdTableNext) // blkSize "round down"!
Item was changed:
----- Method: ObjectMemory>>fwdTableSize: (in category 'gc -- compaction') -----
fwdTableSize: blkSize
"Estimate the number of forwarding blocks available for compaction"
| eom fwdFirst fwdLast |
<inline: false>
+ eom := freeBlock + self baseHeaderSize.
- eom := freeBlock + BaseHeaderSize.
"use all memory free between freeBlock and memoryLimit for forwarding table"
"Note: Forward blocks must be quadword aligned."
+ fwdFirst := (eom + self baseHeaderSize + 7) bitAnd: WordMask-7.
- fwdFirst := (eom + BaseHeaderSize + 7) bitAnd: WordMask-7.
self flag: #Dan. "Above line does not do what it says (quadword is 16 or 32 bytes)"
fwdLast := memoryLimit - blkSize. "last forwarding table entry"
"return the number of forwarding blocks available"
^ (fwdLast - fwdFirst) // blkSize "round down"!
Item was changed:
----- Method: ObjectMemory>>growToAccomodateContainerWithNumSlots: (in category 'allocation') -----
growToAccomodateContainerWithNumSlots: numSlots
"Grow memory to accomodate a container (an Array) with numSlots.
Grow by at least the growHeadroom. Supports allInstancesOf: and allObjects."
| delta |
+ delta := (headerTypeBytes at: HeaderTypeSizeAndClass) / self wordSize
- delta := (headerTypeBytes at: HeaderTypeSizeAndClass) / BytesPerWord
+ 1
+ numSlots
+ * self bytesPerOop.
- * BytesPerOop.
self growObjectMemory: (growHeadroom max: delta)!
Item was changed:
----- Method: ObjectMemory>>headerWhileForwardingOf: (in category 'gc -- compaction') -----
headerWhileForwardingOf: oop
"Answer the header of the argument even though
it may have its header word in a forwarding block."
| header fwdBlock |
<inline: true>
header := self longAt: oop.
(header bitAnd: MarkBit) ~= 0 ifTrue:
["oop is forwarded; get its real header from its forwarding table entry"
fwdBlock := (header bitAnd: AllButMarkBitAndTypeMask) << 1.
self assert: (self fwdBlockValid: fwdBlock).
+ header := self longAt: fwdBlock + self wordSize].
- header := self longAt: fwdBlock + BytesPerWord].
^header!
Item was changed:
----- Method: ObjectMemory>>imageSegmentVersion (in category 'image segment in/out') -----
imageSegmentVersion
| wholeWord |
"a more complex version that tells both the word reversal and the endianness of the machine it came from. Low half of word is 6502. Top byte is top byte of #doesNotUnderstand: on this machine. ($d on the Mac or $s on the PC)"
+ wholeWord := self longAt: (self splObj: SelectorDoesNotUnderstand) + self baseHeaderSize.
- wholeWord := self longAt: (self splObj: SelectorDoesNotUnderstand) + BaseHeaderSize.
"first data word, 'does' "
^ self imageFormatVersion bitOr: (wholeWord bitAnd: 16rFF000000)!
Item was changed:
----- Method: ObjectMemory>>incCompBody (in category 'gc -- compaction') -----
incCompBody
"Move objects to consolidate free space into one big chunk. Return the newly created free chunk."
| bytesFreed |
<inline: false>
"reserve memory for forwarding table"
+ self fwdTableInit: self wordSize*2. "Two-word blocks"
- self fwdTableInit: BytesPerWord*2. "Two-word blocks"
"assign new oop locations, reverse their headers, and initialize forwarding blocks"
bytesFreed := self incCompMakeFwd.
"update pointers to point at new oops"
self mapPointersInObjectsFrom: youngStart to: endOfMemory.
"move the objects and restore their original headers; return the new free chunk"
^ self incCompMove: bytesFreed!
Item was changed:
----- Method: ObjectMemory>>incCompMakeFwd (in category 'gc -- compaction') -----
incCompMakeFwd
"Create and initialize forwarding blocks for all non-free objects
following compStart. If the supply of forwarding blocks is exhausted,
set compEnd to the first chunk above the area to be
compacted; otherwise, set it to endOfMemory. Return the number of
bytes to be freed."
| bytesFreed oop fwdBlock newOop |
<inline: false>
bytesFreed := 0.
oop := self oopFromChunk: compStart.
[self oop: oop isLessThan: endOfMemory]
whileTrue: [
statMkFwdCount := statMkFwdCount + 1.
(self isFreeObject: oop)
ifTrue: [bytesFreed := bytesFreed + (self sizeOfFree: oop)]
ifFalse: ["create a forwarding block for oop"
+ fwdBlock := self fwdBlockGet: self wordSize*2.
- fwdBlock := self fwdBlockGet: BytesPerWord*2.
"Two-word block"
fwdBlock = nil
ifTrue: ["stop; we have used all available forwarding blocks"
compEnd := self chunkFromOop: oop.
^ bytesFreed].
newOop := oop - bytesFreed.
self initForwardBlock: fwdBlock mapping: oop to: newOop withBackPtr: false].
oop := self objectAfterWhileForwarding: oop].
compEnd := endOfMemory.
^ bytesFreed!
Item was changed:
----- Method: ObjectMemory>>incCompMove: (in category 'gc -- compaction') -----
incCompMove: bytesFreed
"Move all non-free objects between compStart and compEnd to their new
locations, restoring their headers in the process. Create a new free
block at the end of memory. Return the newly created free chunk. "
"Note: The free block used by the allocator always must be the last free
block in memory. It may take several compaction passes to make all
free space bubble up to the end of memory."
| oop next fwdBlock newOop header bytesToMove firstWord lastWord newFreeChunk sz target |
<inline: false>
<var: #firstWord type: 'usqInt'>
<var: #lastWord type: 'usqInt'>
<var: #w type: 'usqInt'>
newOop := nil.
oop := self oopFromChunk: compStart.
[self oop: oop isLessThan: compEnd] whileTrue:
[statCompMoveCount := statCompMoveCount + 1.
next := self objectAfterWhileForwarding: oop.
(self isFreeObject: oop) ifFalse:
["a moving object; unwind its forwarding block"
fwdBlock := self forwardingPointerOf: oop.
self assert: (self fwdBlockValid: fwdBlock).
newOop := self longAt: fwdBlock.
+ header := self longAt: fwdBlock + self wordSize.
- header := self longAt: fwdBlock + BytesPerWord.
self longAt: oop put: header. "restore the original header"
bytesToMove := oop - newOop. "move the oop (including any extra header words) "
sz := self sizeBitsOf: oop.
firstWord := oop - (self extraHeaderBytes: oop).
+ lastWord := oop + sz - self baseHeaderSize.
- lastWord := oop + sz - BaseHeaderSize.
target := firstWord - bytesToMove.
+ firstWord to: lastWord by: self wordSize do:
- firstWord to: lastWord by: BytesPerWord do:
[:w |
self longAt: target put: (self longAt: w).
+ target := target + self wordSize]].
- target := target + BytesPerWord]].
oop := next].
newOop = nil
ifTrue: ["no objects moved"
oop := self oopFromChunk: compStart.
((self isFreeObject: oop) and: [(self objectAfter: oop) = (self oopFromChunk: compEnd)])
ifTrue: [newFreeChunk := oop]
ifFalse: [newFreeChunk := freeBlock]]
ifFalse: ["initialize the newly freed memory chunk"
"newOop is the last object moved; free chunk starts
right after it"
newFreeChunk := newOop + (self sizeBitsOf: newOop).
self setSizeOfFree: newFreeChunk to: bytesFreed].
self assert: (self objectAfter: newFreeChunk) = (self oopFromChunk: compEnd).
(self objectAfter: newFreeChunk) = endOfMemory
ifTrue: [self initializeMemoryFirstFree: newFreeChunk]
ifFalse: ["newFreeChunk is not at end of memory; re-install freeBlock "
self initializeMemoryFirstFree: freeBlock].
^ newFreeChunk!
Item was changed:
----- Method: ObjectMemory>>initForwardBlock:mapping:to:withBackPtr: (in category 'gc -- compaction') -----
initForwardBlock: fwdBlock mapping: oop to: newOop withBackPtr: backFlag
"Initialize the given forwarding block to map oop to newOop,
and replace oop's header with a pointer to the fowarding
block. "
"Details: The mark bit is used to indicate that an oop is
forwarded. When an oop is forwarded, its header (minus the
mark bit) contains the address of its forwarding block. (The
forwarding block address is actually shifted right by one bit
so that its top-most bit does not conflict with the header's
mark bit; since fowarding blocks are stored on word
boundaries, the low two bits of the address are always zero.)
The first word of the forwarding block is the new oop; the
second word is the oop's orginal header. In the case of a
forward become, a four-word block is used, with the third
field being a backpointer to the old oop (for header fixup),
and the fourth word is unused. The type bits of the
forwarding header are the same as those of the original
header. "
| originalHeader originalHeaderType |
<inline: true>
- <asmLabel: false>
originalHeader := self longAt: oop.
self assert: fwdBlock ~= nil. "ran out of forwarding blocks in become"
self assert: (originalHeader bitAnd: MarkBit) = 0. "'object already has a forwarding table entry"
originalHeaderType := originalHeader bitAnd: TypeMask.
self longAt: fwdBlock put: newOop.
+ self longAt: fwdBlock + self wordSize put: originalHeader.
+ backFlag ifTrue: [self longAt: fwdBlock + (self wordSize*2) put: oop].
- self longAt: fwdBlock + BytesPerWord put: originalHeader.
- backFlag ifTrue: [self longAt: fwdBlock + (BytesPerWord*2) put: oop].
self longAt: oop put: (fwdBlock >> 1 bitOr: (MarkBit bitOr: originalHeaderType))!
Item was changed:
----- Method: ObjectMemory>>initializeMemoryFirstFree: (in category 'initialization') -----
initializeMemoryFirstFree: firstFree
"Initialize endOfMemory to the top of oop storage space, reserving some space for forwarding blocks, and create the freeBlock from which space is allocated. Also create a fake free chunk at endOfMemory to act as a sentinal for memory scans. "
"Note: The amount of space reserved for forwarding blocks should be chosen to ensure that incremental compactions can usually be done in a single pass. However, there should be enough forwarding blocks so a full compaction can be done in a reasonable number of passes, say ten. (A full compaction requires N object-moving passes, where N = number of non-garbage objects / number of forwarding blocks).
di 11/18/2000 Re totalObjectCount: Provide a margin of one byte per object to be used for forwarding pointers at GC time. Since fwd blocks are 8 bytes, this means an absolute worst case of 8 passes to compact memory. In most cases it will be adequate to do compaction in a single pass. "
| fwdBlockBytes |
"reserve space for forwarding blocks"
+ fwdBlockBytes := totalObjectCount bitAnd: WordMask - self wordSize + 1.
+ (self oop: memoryLimit - fwdBlockBytes isGreaterThanOrEqualTo: firstFree + self baseHeaderSize)
- fwdBlockBytes := totalObjectCount bitAnd: WordMask - BytesPerWord + 1.
- (self oop: memoryLimit - fwdBlockBytes isGreaterThanOrEqualTo: firstFree + BaseHeaderSize)
ifFalse: ["reserve enough space for a minimal free block of BaseHeaderSize bytes"
+ fwdBlockBytes := memoryLimit - (firstFree + self baseHeaderSize)].
- fwdBlockBytes := memoryLimit - (firstFree + BaseHeaderSize)].
"set endOfMemory and initialize freeBlock"
self setEndOfMemory: memoryLimit - fwdBlockBytes.
freeBlock := firstFree.
self setSizeOfFree: freeBlock to: endOfMemory - firstFree. "bytes available for oops"
"make a fake free chunk at endOfMemory for use as a sentinel in memory scans"
+ self setSizeOfFree: endOfMemory to: self baseHeaderSize.
- self setSizeOfFree: endOfMemory to: BaseHeaderSize.
DoAssertionChecks
ifTrue: [(freeBlock < endOfMemory and: [endOfMemory < memoryLimit])
ifFalse: [self error: 'error in free space computation'].
(self oopFromChunk: endOfMemory) = endOfMemory
ifFalse: [self error: 'header format must have changed'].
(self objectAfter: freeBlock) = endOfMemory
ifFalse: [self error: 'free block not properly initialized']]!
Item was changed:
----- Method: ObjectMemory>>initializeObjectMemory: (in category 'initialization') -----
initializeObjectMemory: bytesToShift
"Initialize object memory variables at startup time. Assume endOfMemory is initially set (by the image-reading code) to the end of the last object in the image. Initialization redefines endOfMemory to be the end of the object allocation area based on the total available memory, but reserving some space for forwarding blocks."
"Assume: image reader initializes the following variables:
memory
endOfMemory
memoryLimit
specialObjectsOop
lastHash
"
"di 11/18/2000 fix slow full GC"
<inline: false>
"Catch mis-initializations leading to bad translations to C"
+ self assert: self baseHeaderSize = self wordSize.
- self assert: BaseHeaderSize = BytesPerWord.
"set the start of the young object space"
youngStart := endOfMemory.
"image may be at a different address; adjust oops for new location"
totalObjectCount := self adjustAllOopsBy: bytesToShift.
self initializeMemoryFirstFree: endOfMemory. "initializes endOfMemory, freeBlock"
specialObjectsOop := specialObjectsOop + bytesToShift.
"heavily used special objects"
nilObj := self splObj: NilObject.
falseObj := self splObj: FalseObject.
trueObj := self splObj: TrueObject.
rootTableCount := 0.
rootTableOverflowed := false.
freeContexts := NilContext.
freeLargeContexts := NilContext.
allocationCount := 0.
lowSpaceThreshold := 0.
signalLowSpace := false.
compStart := 0.
compEnd := 0.
fwdTableNext := 0.
fwdTableLast := 0.
remapBufferCount := 0.
allocationsBetweenGCs := 4000. "do incremental GC after this many allocations"
tenuringThreshold := 2000. "tenure all suriving objects if count is over this threshold"
growHeadroom := 4*1024*1024. "four megabyte of headroom when growing"
shrinkThreshold := 8*1024*1024. "eight megabyte of free space before shrinking"
"garbage collection statistics"
statFullGCs := 0.
statFullGCUsecs := 0.
statIncrGCs := 0.
statIncrGCUsecs := 0.
statTenures := 0.
statRootTableOverflows := 0.
statGrowMemory := 0.
statShrinkMemory := 0.
forceTenureFlag := 0.
gcBiasToGrow := 0.
gcBiasToGrowGCLimit := 0.
extraRootCount := 0.
gcStartUsecs := 0!
Item was changed:
----- Method: ObjectMemory>>instanceSizeOf: (in category 'interpreter access') -----
instanceSizeOf: classObj
<api>
"Answer the number of slots in a class. For example the instanceSizeOf:
ClassPoint is 2, for the x & y slots. The instance size of non-pointer classes is 0."
| classHdr sizeHiBits byteSize |
self assert: (self addressCouldBeObj: classObj).
classHdr := self formatOfClass: classObj. "Low 2 bits are 0"
"Compute the size of instances of the class (used for fixed field classes only)"
sizeHiBits := classHdr >> 9 bitAnd: 16r300.
byteSize := (classHdr bitAnd: SizeMask) + sizeHiBits. "size in bytes -- low 2 bits are 0"
+ ^byteSize - self baseHeaderSize / self wordSize!
- ^byteSize - BaseHeaderSize / BytesPerWord!
Item was changed:
----- Method: ObjectMemory>>instantiateClass:indexableSize: (in category 'interpreter access') -----
instantiateClass: classPointer indexableSize: size
"NOTE: This method supports the backward-compatible split instSize field of the
class format word. The sizeHiBits will go away and other shifts change by 2
when the split fields get merged in an (incompatible) image change."
<api>
| hash header1 header2 cClass byteSize format binc header3 hdrSize sizeHiBits bm1 classFormat |
<inline: false>
self assert: size >= 0. "'cannot have a negative indexable field count"
hash := self newObjectHash.
classFormat := self formatOfClass: classPointer.
"Low 2 bits are 0"
header1 := (classFormat bitAnd: 16r1FF00) bitOr: (hash bitAnd: HashMaskUnshifted) << HashBitsOffset.
header2 := classPointer.
sizeHiBits := (classFormat bitAnd: 16r60000) >> 9.
cClass := header1 bitAnd: CompactClassMask. "compact class field from format word"
byteSize := (classFormat bitAnd: SizeMask + Size4Bit) + sizeHiBits.
"size in bytes -- low 2 bits are 0"
"Note this byteSize comes from the format word of the class which is pre-shifted
to 4 bytes per field. Need another shift for 8 bytes per word..."
+ byteSize := byteSize << (self shiftForWord-2).
- byteSize := byteSize << (ShiftForWord-2).
format := self formatOfHeader: classFormat.
self flag: #sizeLowBits.
format < self firstByteFormat
ifTrue:
[format = self firstLongFormat
ifTrue: "long32 bitmaps"
+ [bm1 := self wordSize-1.
- [bm1 := BytesPerWord-1.
byteSize := byteSize + (size * 4) + bm1 bitAnd: LongSizeMask. "round up"
binc := bm1 - ((size * 4) + bm1 bitAnd: bm1). "odd bytes"
"extra low bit (4) for 64-bit VM goes in 4-bit (betw hdr bits and sizeBits)"
header1 := header1 bitOr: (binc bitAnd: 4)]
ifFalse: "Arrays and 64-bit bitmaps"
+ [byteSize := byteSize + (size * self wordSize)]]
- [byteSize := byteSize + (size * BytesPerWord)]]
ifFalse:
["Strings and Methods"
+ bm1 := self wordSize-1.
- bm1 := BytesPerWord-1.
byteSize := byteSize + size + bm1 bitAnd: LongSizeMask. "round up"
binc := bm1 - (size + bm1 bitAnd: bm1). "odd bytes"
"low bits of byte size go in format field"
header1 := header1 bitOr: (binc bitAnd: 3) << self instFormatFieldLSB.
"extra low bit (4) for 64-bit VM goes in 4-bit (betw hdr bits and sizeBits)"
header1 := header1 bitOr: (binc bitAnd: 4)].
byteSize > 255 "requires size header word/full header"
ifTrue: [header3 := byteSize. hdrSize := 3]
ifFalse: [header1 := header1 bitOr: byteSize. hdrSize := cClass = 0 ifTrue: [2] ifFalse: [1]].
^self allocate: byteSize headerSize: hdrSize h1: header1 h2: header2 h3: header3 doFill: true format: format!
Item was changed:
----- Method: ObjectMemory>>instantiateSmallClass:sizeInBytes: (in category 'interpreter access') -----
instantiateSmallClass: classPointer sizeInBytes: sizeInBytes
"This version of instantiateClass assumes that the total object
size is under 256 bytes, the limit for objects with only one or
two header words. Note that the size is specified in bytes
and should include 4 or 8 bytes for the base header word.
NOTE this code will only work for sizes that are an integral number of words
(like not a 32-bit LargeInteger in a 64-bit system).
May cause a GC.
Note that the created small object IS NOT FILLED and must be completed before returning it to Squeak. Since this call is used in routines that do jsut that we are safe. Break this rule and die."
| hash header1 header2 hdrSize |
+ (sizeInBytes bitAnd: (self wordSize-1)) = 0 ifFalse:
- (sizeInBytes bitAnd: (BytesPerWord-1)) = 0 ifFalse:
[self error: 'size must be integral number of words'].
hash := self newObjectHash.
header1 := (hash bitAnd: HashMaskUnshifted) << HashBitsOffset bitOr: (self formatOfClass: classPointer).
header2 := classPointer.
hdrSize := (header1 bitAnd: CompactClassMask) > 0 "is this a compact class"
ifTrue: [1]
ifFalse: [2].
header1 := header1 + (sizeInBytes - (header1 bitAnd: SizeMask+Size4Bit)).
^ self allocate: sizeInBytes headerSize: hdrSize h1: header1 h2: header2 h3: 0 doFill: false format: 0!
Item was changed:
----- Method: ObjectMemory>>isClassOfNonImm:equalTo: (in category 'header access') -----
isClassOfNonImm: oop equalTo: classOop
"Answer if the given (non-immediate) object is an instance of the given class."
| ccIndex cl |
<inline: true>
- <asmLabel: false>
(self isIntegerObject: oop) ifTrue:
[^false].
cl := (ccIndex := self compactClassIndexOf: oop) = 0
ifTrue: [(self classHeader: oop) bitAnd: AllButTypeMask]
ifFalse: [self compactClassAt: ccIndex].
^cl = classOop!
Item was changed:
----- Method: ObjectMemory>>isClassOfNonImm:equalTo:compactClassIndex: (in category 'object access') -----
isClassOfNonImm: oop equalTo: classOop compactClassIndex: compactClassIndex
"Answer if the given (non-immediate) object is an instance of the given class
that may have a compactClassIndex (if compactClassIndex is non-zero).
N.B. Inlining and/or compiler optimization should result in classOop not being
accessed if oop's compact class index and compactClassIndex are non-zero.
N.B. Generally one cannot assume that if compactClassIndex is non-zero the
instances of the corresponding class always have the compactClassIndex
because the compact class index is only non-zero in short header instances."
| ccIndex |
<inline: true>
- <asmLabel: false>
self assert: (self isIntegerObject: oop) not.
ccIndex := self compactClassIndexOf: oop.
ccIndex = 0 ifTrue:
[^((self classHeader: oop) bitAnd: AllButTypeMask) = classOop].
compactClassIndex ~= 0 ifTrue:
[^compactClassIndex = ccIndex].
^classOop = (self compactClassAt: ccIndex)!
Item was changed:
----- Method: ObjectMemory>>isImmutableWhileForwarding: (in category 'gc -- compaction') -----
isImmutableWhileForwarding: oop
"The given object may have its header word in a forwarding block. Find
the value of the isImmutable flag in the object in spite of this obstacle. "
| header fwdBlock |
<inline: true>
header := self longAt: oop.
(header bitAnd: MarkBit) ~= 0 ifTrue:
["oop is forwarded; get its real header from its forwarding table entry"
fwdBlock := (header bitAnd: AllButMarkBitAndTypeMask) << 1.
DoAssertionChecks ifTrue:
[self fwdBlockValidate: fwdBlock].
+ header := self longAt: fwdBlock + self wordSize].
- header := self longAt: fwdBlock + BytesPerWord].
^(header bitAnd: ImmutabilityBit) ~= 0!
Item was changed:
----- Method: ObjectMemory>>lastPointerOf: (in category 'object enumeration') -----
lastPointerOf: objOop
"Return the byte offset of the last pointer field of the given object.
Works with CompiledMethods, as well as ordinary objects.
Can be used even when the type bits are not correct."
<api>
<inline: true>
- <asmLabel: false>
| fmt sz header contextSize |
header := self baseHeader: objOop.
fmt := self formatOfHeader: header.
fmt <= self lastPointerFormat ifTrue:
[(fmt = self indexablePointersFormat
and: [self isContextHeader: header])
ifTrue: ["contexts end at the stack pointer"
contextSize := self fetchStackPointerOf: objOop.
+ ^ CtxtTempFrameStart + contextSize * self wordSize].
- ^ CtxtTempFrameStart + contextSize * BytesPerWord].
sz := self sizeBitsOfSafe: objOop.
+ ^sz - self baseHeaderSize "all pointers"].
- ^sz - BaseHeaderSize "all pointers"].
fmt < self firstCompiledMethodFormat ifTrue: [^0]. "no pointers"
"CompiledMethod: contains both pointers and bytes:"
header := self methodHeaderOf: objOop.
^self lastPointerOfMethodHeader: header!
Item was changed:
----- Method: ObjectMemory>>lastPointerOf:recordWeakRoot: (in category 'gc -- mark and sweep') -----
lastPointerOf: objOop recordWeakRoot: recordWeakRoot "<Boolean>"
"Return the byte offset of the last pointer field of the given object.
Works with CompiledMethods, as well as ordinary objects.
Can be used even when the type bits are not correct.
This is a version of lastPointerOf: for markAndTrace:."
| fmt sz header contextSize |
<inline: true>
header := self baseHeader: objOop.
fmt := self formatOfHeader: header.
fmt <= self lastPointerFormat ifTrue:
[fmt >= self indexablePointersFormat ifTrue:
[fmt = self lastPointerFormat ifTrue:
[(recordWeakRoot and: [weakRootCount >= 0]) ifTrue:
["And remember as weak root"
(weakRootCount := weakRootCount + 1) <= WeakRootTableSize ifFalse:
[self error: 'weakRoots table overflow'].
weakRoots at: weakRootCount put: objOop].
"Do not trace the object's indexed fields if it's a weak class"
+ ^(self nonWeakFieldsOf: objOop) * self bytesPerOop].
- ^(self nonWeakFieldsOf: objOop) * BytesPerOop].
"So fmt is 3"
(self isContextHeader: header) ifTrue:
["contexts end at the stack pointer avoiding having to init fields beyond it"
contextSize := self fetchStackPointerOf: objOop.
+ ^CtxtTempFrameStart + contextSize * self bytesPerOop]].
- ^CtxtTempFrameStart + contextSize * BytesPerOop]].
sz := self sizeBitsOfSafe: objOop.
+ ^sz - self baseHeaderSize "all pointers"].
- ^sz - BaseHeaderSize "all pointers"].
fmt < self firstCompiledMethodFormat ifTrue: [^0]. "no pointers"
"CompiledMethod: contains both pointers and bytes:"
header := self methodHeaderOf: objOop.
^self lastPointerOfMethodHeader: header!
Item was changed:
----- Method: ObjectMemory>>lastPointerOfMethodHeader: (in category 'object enumeration') -----
lastPointerOfMethodHeader: methodHeader
"Answer the byte offset of the last pointer field of a
CompiledMethod with the given header."
<inline: true>
- <asmLabel: false>
^(self literalCountOfMethodHeader: methodHeader)
+ + LiteralStart - 1 * self bytesPerOop + self baseHeaderSize!
- + LiteralStart - 1 * BytesPerOop + BaseHeaderSize!
Item was changed:
----- Method: ObjectMemory>>lastPointerWhileForwarding: (in category 'gc -- compaction') -----
lastPointerWhileForwarding: objOop
"The given object may have its header word in a forwarding block. Find
the offset of the last pointer in the object in spite of this obstacle. "
| header fmt size contextSize |
<inline: true>
header := self headerWhileForwardingOf: objOop.
fmt := self formatOfHeader: header.
fmt <= self lastPointerFormat ifTrue:
[(fmt = self indexablePointersFormat
and: [self isContextHeader: header]) ifTrue:
["contexts end at the stack pointer"
contextSize := self nacFetchStackPointerOf: objOop.
self assert: ReceiverIndex + contextSize < (self lengthOf: objOop baseHeader: header format: fmt).
+ ^CtxtTempFrameStart + contextSize * self wordSize].
- ^CtxtTempFrameStart + contextSize * BytesPerWord].
"do sizeBitsOf: using the header we obtained"
(header bitAnd: TypeMask) = HeaderTypeSizeAndClass
ifTrue: [size := (self sizeHeader: objOop) bitAnd: AllButTypeMask]
ifFalse: [size := header bitAnd: SizeMask].
+ ^size - self baseHeaderSize].
- ^size - BaseHeaderSize].
fmt < self firstCompiledMethodFormat ifTrue: [^0]. "no pointers"
"CompiledMethod: contains both pointers and bytes"
self assert: (self isCompiledMethodHeader: header).
header := self noCheckMethodHeaderOf: objOop.
^self lastPointerOfMethodHeader: header!
Item was changed:
----- Method: ObjectMemory>>lengthOf: (in category 'object access') -----
lengthOf: oop
"Return the number of indexable bytes or words in the given object. Assume the argument is not an integer. For a CompiledMethod, the size of the method header (in bytes) should be subtracted from the result."
<api>
| header |
<inline: true>
- <asmLabel: false>
header := self baseHeader: oop.
^self lengthOf: oop baseHeader: header format: (self formatOfHeader: header)!
Item was changed:
----- Method: ObjectMemory>>lengthOf:baseHeader:format: (in category 'object access') -----
lengthOf: oop baseHeader: hdr format: fmt
"Return the number of fixed and indexable bytes, words, or object pointers in the
given object. Assume the given oop is not an integer. For a CompiledMethod, the size
of the method header (in bytes) should be subtracted from the result of this method."
| sz |
<inline: true>
- <asmLabel: false>
(hdr bitAnd: TypeMask) = HeaderTypeSizeAndClass
ifTrue: [ sz := (self sizeHeader: oop) bitAnd: LongSizeMask ]
ifFalse: [ sz := (hdr bitAnd: SizeMask)].
sz := sz - (hdr bitAnd: Size4Bit).
fmt <= self lastPointerFormat
+ ifTrue: [ ^ (sz - self baseHeaderSize) >> self shiftForWord "words"].
- ifTrue: [ ^ (sz - BaseHeaderSize) >> ShiftForWord "words"].
^fmt < self firstByteFormat
+ ifTrue: [(sz - self baseHeaderSize) >> 2 "32-bit longs"]
+ ifFalse: [(sz - self baseHeaderSize) - (fmt bitAnd: 3) "bytes"]!
- ifTrue: [(sz - BaseHeaderSize) >> 2 "32-bit longs"]
- ifFalse: [(sz - BaseHeaderSize) - (fmt bitAnd: 3) "bytes"]!
Item was changed:
----- Method: ObjectMemory>>loadImageSegmentFrom:outPointers: (in category 'image segment in/out') -----
loadImageSegmentFrom: segmentWordArray outPointers: outPointerArray
"This primitive is called from Squeak as...
<imageSegment> loadSegmentFrom: aWordArray outPointers: anArray."
"This primitive will load a binary image segment created by primitiveStoreImageSegment. It expects the outPointer array to be of the proper size, and the wordArray to be well formed. It will return as its value the original array of roots, and the erstwhile segmentWordArray will have been truncated to a size of one word, i.e. retaining the version stamp. If this primitive should fail, the segmentWordArray will, sadly, have been reduced to an unrecognizable and unusable jumble. But what more could you have done with it anyway?"
| endSeg segOop fieldPtr fieldOop doingClass lastPtr extraSize mapOop lastOut outPtr hdrTypeBits header data |
<inline: false>
<var: #endSeg type: #usqInt>
<var: #segOop type: #usqInt>
<var: #fieldPtr type: #usqInt>
<var: #lastOut type: #usqInt>
<var: #outPtr type: #usqInt>
<var: #lastPtr type: #usqInt>
DoAssertionChecks ifTrue: [self verifyCleanHeaders].
lastOut := outPointerArray + (self lastPointerOf: outPointerArray).
+ endSeg := segmentWordArray + (self sizeBitsOf: segmentWordArray) - self baseHeaderSize.
- endSeg := segmentWordArray + (self sizeBitsOf: segmentWordArray) - BaseHeaderSize.
"Version check. Byte order of the WordArray now"
+ data := self longAt: segmentWordArray + self baseHeaderSize.
- data := self longAt: segmentWordArray + BaseHeaderSize.
(self readableFormat: (data bitAnd: 16rFFFF "low 2 bytes")) ifFalse:
"Not readable -- try again with reversed bytes..."
+ [self reverseBytesFrom: segmentWordArray + self baseHeaderSize to: endSeg + self wordSize.
+ data := self longAt: segmentWordArray + self baseHeaderSize.
- [self reverseBytesFrom: segmentWordArray + BaseHeaderSize to: endSeg + BytesPerWord.
- data := self longAt: segmentWordArray + BaseHeaderSize.
(self readableFormat: (data bitAnd: 16rFFFF "low 2 bytes")) ifFalse:
"Still NG -- put things back and fail"
+ [self reverseBytesFrom: segmentWordArray + self baseHeaderSize to: endSeg + self wordSize.
- [self reverseBytesFrom: segmentWordArray + BaseHeaderSize to: endSeg + BytesPerWord.
DoAssertionChecks ifTrue: [self verifyCleanHeaders].
^PrimErrBadArgument]].
"Reverse the Byte type objects if the data is from opposite endian machine.
Test top byte. $d on the Mac or $s on the PC. Rest of word is equal."
(data >> 16) = (self imageSegmentVersion >> 16)
ifFalse: "Reverse the byte-type objects once"
+ [segOop := self oopFromChunk: segmentWordArray + self baseHeaderSize + self wordSize.
- [segOop := self oopFromChunk: segmentWordArray + BaseHeaderSize + BytesPerWord.
"Oop of first embedded object"
self byteSwapByteObjectsFrom: segOop
+ to: endSeg + self wordSize
- to: endSeg + BytesPerWord
flipFloatsIf: false].
"Proceed through the segment, remapping pointers..."
+ segOop := self oopFromChunk: segmentWordArray + self baseHeaderSize + self wordSize.
- segOop := self oopFromChunk: segmentWordArray + BaseHeaderSize + BytesPerWord.
[segOop <= endSeg] whileTrue:
[(self headerType: segOop) <= 1
ifTrue: ["This object has a class field (type = 0 or 1) -- start with that."
+ fieldPtr := segOop - self wordSize. doingClass := true]
- fieldPtr := segOop - BytesPerWord. doingClass := true]
ifFalse: ["No class field -- start with first data field"
+ fieldPtr := segOop + self baseHeaderSize. doingClass := false].
- fieldPtr := segOop + BaseHeaderSize. doingClass := false].
lastPtr := segOop + (self lastPointerOf: segOop). "last field"
lastPtr > endSeg ifTrue:
[DoAssertionChecks ifTrue: [self verifyCleanHeaders].
^PrimErrBadIndex "out of bounds"].
"Go through all oops, remapping them..."
[fieldPtr > lastPtr] whileFalse:
["Examine each pointer field"
fieldOop := self longAt: fieldPtr.
doingClass ifTrue:
[hdrTypeBits := self headerType: fieldPtr.
fieldOop := fieldOop - hdrTypeBits].
(self isIntegerObject: fieldOop)
ifTrue:
["Integer -- nothing to do"
+ fieldPtr := fieldPtr + self wordSize]
- fieldPtr := fieldPtr + BytesPerWord]
ifFalse:
[(fieldOop bitAnd: 3) = 0 ifFalse:
[^PrimErrBadIndex "bad oop"].
(fieldOop bitAnd: 16r80000000) = 0
ifTrue: ["Internal pointer -- add segment offset"
mapOop := fieldOop + segmentWordArray]
ifFalse: ["External pointer -- look it up in outPointers"
outPtr := outPointerArray + (fieldOop bitAnd: 16r7FFFFFFF).
outPtr > lastOut ifTrue:
[^PrimErrBadIndex "out of bounds"].
mapOop := self longAt: outPtr].
doingClass
ifTrue: [self longAt: fieldPtr put: mapOop + hdrTypeBits.
fieldPtr := fieldPtr + 8.
doingClass := false]
ifFalse: [self longAt: fieldPtr put: mapOop.
+ fieldPtr := fieldPtr + self wordSize].
- fieldPtr := fieldPtr + BytesPerWord].
segOop < youngStart ifTrue:
[self possibleRootStoreInto: segOop value: mapOop]]].
segOop := self objectAfter: segOop].
"Again, proceed through the segment checking consistency..."
+ segOop := self oopFromChunk: segmentWordArray + self baseHeaderSize + self wordSize.
- segOop := self oopFromChunk: segmentWordArray + BaseHeaderSize + BytesPerWord.
[segOop <= endSeg] whileTrue:
[(self oopHasAcceptableClass: segOop) ifFalse:
[^PrimErrInappropriate "inconsistency"].
+ fieldPtr := segOop + self baseHeaderSize. "first field"
- fieldPtr := segOop + BaseHeaderSize. "first field"
lastPtr := segOop + (self lastPointerOf: segOop). "last field"
"Go through all oops, remapping them..."
[fieldPtr > lastPtr] whileFalse:
["Examine each pointer field"
fieldOop := self longAt: fieldPtr.
(self oopHasAcceptableClass: fieldOop) ifFalse:
[^PrimErrInappropriate "inconsistency"].
+ fieldPtr := fieldPtr + self wordSize].
- fieldPtr := fieldPtr + BytesPerWord].
segOop := self objectAfter: segOop].
"Truncate the segment word array to size = BytesPerWord (vers stamp only)"
extraSize := self extraHeaderBytes: segmentWordArray.
hdrTypeBits := self headerType: segmentWordArray.
extraSize = 8
+ ifTrue: [self longAt: segmentWordArray-extraSize put: self baseHeaderSize + self wordSize + hdrTypeBits]
- ifTrue: [self longAt: segmentWordArray-extraSize put: BaseHeaderSize + BytesPerWord + hdrTypeBits]
ifFalse: [header := self longAt: segmentWordArray.
self longAt: segmentWordArray
+ put: header - (header bitAnd: SizeMask) + self baseHeaderSize + self wordSize].
- put: header - (header bitAnd: SizeMask) + BaseHeaderSize + BytesPerWord].
"and return the roots array which was first in the segment"
DoAssertionChecks ifTrue: [self verifyCleanHeaders].
+ ^self oopFromChunk: segmentWordArray + self baseHeaderSize + self wordSize!
- ^self oopFromChunk: segmentWordArray + BaseHeaderSize + BytesPerWord!
Item was changed:
----- Method: ObjectMemory>>noteAsRoot:headerLoc: (in category 'garbage collection') -----
noteAsRoot: oop headerLoc: headerLoc
"Record that the given oop in the old object area points to an object in the young area.
HeaderLoc is usually = oop, but may be an addr in a forwarding block."
| header |
<inline: true>
- <asmLabel: false>
header := self longAt: headerLoc.
(self isYoungRootHeader: header) ifFalse:
"record oop as root only if not already recorded"
[rootTableCount < RootTableSize
ifTrue:
"record root if there is enough room in the roots table.
IMPORTANT: since clearRootsTable is the only thing that clears root bits
do *not* set the root bit unless an object is in the root table. checking
routines will complain about the root bit being unset instead of the table
being full, but that's life"
[rootTableCount := rootTableCount + 1.
rootTable at: rootTableCount put: oop.
self longAt: headerLoc put: (header bitOr: RootBit).
rootTableCount >= RootTableRedZone ifTrue:
"if we're now in the red zone force an IGC ASAP"
[allocationCount := allocationsBetweenGCs + 1]]
ifFalse: "note overflow; will need to do a fullGC instead of an incremental."
[rootTableOverflowed := true]]!
Item was changed:
----- Method: ObjectMemory>>numBytesOf: (in category 'object access') -----
numBytesOf: objOop
"Answer the number of indexable bytes in the given non-immediate object.
Does not adjust the size of contexts by stackPointer."
<api>
| header sz fmt |
header := self baseHeader: objOop.
sz := (header bitAnd: TypeMask) = HeaderTypeSizeAndClass
ifTrue: [(self sizeHeader: objOop) bitAnd: AllButTypeMask]
ifFalse: [header bitAnd: SizeMask].
fmt := self formatOfHeader: header.
^fmt < self firstByteFormat
+ ifTrue: [(sz - self baseHeaderSize)] "words"
+ ifFalse: [(sz - self baseHeaderSize) - (fmt bitAnd: 3)] "bytes"!
- ifTrue: [(sz - BaseHeaderSize)] "words"
- ifFalse: [(sz - BaseHeaderSize) - (fmt bitAnd: 3)] "bytes"!
Item was changed:
----- Method: ObjectMemory>>numSlotsOf: (in category 'object access') -----
numSlotsOf: obj
"Answer the number of oop-sized elements in the given object.
Unlike lengthOf: this does not adjust the length of a context
by the stackPointer and so can be used e.g. by cloneContext:"
<api>
| header sz |
header := self baseHeader: obj.
sz := (header bitAnd: TypeMask) = HeaderTypeSizeAndClass
ifTrue: [(self sizeHeader: obj) bitAnd: AllButTypeMask]
ifFalse: [header bitAnd: SizeMask].
+ ^sz - self baseHeaderSize >> self shiftForWord!
- ^sz - BaseHeaderSize >> ShiftForWord!
Item was changed:
----- Method: ObjectMemory>>objectAfter: (in category 'object enumeration') -----
objectAfter: oop
"Return the object or free chunk immediately following the
given object or free chunk in memory. Return endOfMemory
when enumeration is complete."
| sz |
<api>
<inline: true>
- <asmLabel: false>
DoAssertionChecks
ifTrue: [(self oop: oop isGreaterThanOrEqualTo:endOfMemory)
ifTrue: [self error: 'no objects after the end of memory']].
(self isFreeObject: oop)
ifTrue: [sz := self sizeOfFree: oop]
ifFalse: [sz := self sizeBitsOf: oop].
^ self oopFromChunk: oop + sz!
Item was changed:
----- Method: ObjectMemory>>objectAfterWhileForwarding: (in category 'gc -- compaction') -----
objectAfterWhileForwarding: oop
"Return the oop of the object after the given oop when the actual header of the oop may be in the forwarding table."
| header fwdBlock realHeader sz |
<inline: true>
- <asmLabel: false>
header := self longAt: oop.
(header bitAnd: MarkBit) = 0 ifTrue: [ ^ self objectAfter: oop ]. "oop not forwarded"
"Assume: mark bit cannot be set on a free chunk, so if we get here,
oop is not free and it has a forwarding table entry"
fwdBlock := (header bitAnd: AllButMarkBitAndTypeMask) << 1.
self assert: (self fwdBlockValid: fwdBlock).
+ realHeader := self longAt: fwdBlock + self wordSize.
- realHeader := self longAt: fwdBlock + BytesPerWord.
"following code is like sizeBitsOf:"
(realHeader bitAnd: TypeMask) = HeaderTypeSizeAndClass
ifTrue: [ sz := (self sizeHeader: oop) bitAnd: LongSizeMask ]
ifFalse: [ sz := realHeader bitAnd: SizeMask ].
^ self oopFromChunk: (oop + sz)!
Item was changed:
----- Method: ObjectMemory>>objectIsImmutableAndReferencesForwarded: (in category 'gc -- compaction') -----
objectIsImmutableAndReferencesForwarded: oop
"Answer if an object is immutable and references a forwarded object. Used to fail become for immutable referents of becomees."
"Note: The given oop may be forwarded itself, which means that its real header is in its forwarding table entry."
| fieldOffset fieldOop |
<inline: true>
(self isImmutableWhileForwarding: oop) ifTrue:
[fieldOffset := self lastPointerWhileForwarding: oop.
+ [fieldOffset >= self baseHeaderSize] whileTrue:
- [fieldOffset >= BaseHeaderSize] whileTrue:
[fieldOop := self longAt: oop + fieldOffset.
(self isObjectForwarded: fieldOop) ifTrue: [^true].
+ fieldOffset := fieldOffset - self wordSize]].
- fieldOffset := fieldOffset - BytesPerWord]].
^false!
Item was changed:
----- Method: ObjectMemory>>okayOop: (in category 'debug support') -----
okayOop: signedOop
"Verify that the given oop is legitimate. Check address, header, and size but not class."
| sz type fmt unusedBit oop |
<var: #oop type: #usqInt>
oop := self cCoerce: signedOop to: #usqInt.
"address and size checks"
(self isIntegerObject: oop) ifTrue: [ ^true ].
(self oop: oop isGreaterThanOrEqualTo: self startOfMemory andLessThan: endOfMemory)
ifFalse: [ self error: 'oop is not a valid address'. ^false ].
+ ((oop \\ self wordSize) = 0)
- ((oop \\ BytesPerWord) = 0)
ifFalse: [ self error: 'oop is not a word-aligned address'. ^false ].
sz := self sizeBitsOf: oop.
(oop + sz) < endOfMemory
ifFalse: [ self error: 'oop size would make it extend beyond the end of memory'. ^false ].
"header type checks"
type := self headerType: oop.
type = HeaderTypeFree
ifTrue: [ self error: 'oop is a free chunk, not an object'. ^false ].
type = HeaderTypeShort ifTrue: [
(self compactClassIndexOf: oop) = 0
ifTrue: [ self error: 'cannot have zero compact class field in a short header'. ^false ].
].
type = HeaderTypeClass ifTrue: [
+ ((oop >= self wordSize) and: [(self headerType: oop - self wordSize) = type])
- ((oop >= BytesPerWord) and: [(self headerType: oop - BytesPerWord) = type])
ifFalse: [ self error: 'class header word has wrong type'. ^false ].
].
type = HeaderTypeSizeAndClass ifTrue: [
+ ((oop >= (self wordSize*2)) and:
+ [(self headerType: oop - (self wordSize*2)) = type and:
+ [(self headerType: oop - self wordSize) = type]])
- ((oop >= (BytesPerWord*2)) and:
- [(self headerType: oop - (BytesPerWord*2)) = type and:
- [(self headerType: oop - BytesPerWord) = type]])
ifFalse: [ self error: 'class header word has wrong type'. ^false ].
].
"format check"
fmt := self formatOf: oop.
((fmt = 5) | (fmt = 7))
ifTrue: [ self error: 'oop has an unknown format type'. ^false ].
"mark and root bit checks"
unusedBit := 16r20000000.
+ self wordSize = 8
- BytesPerWord = 8
ifTrue:
[unusedBit := unusedBit << 16.
unusedBit := unusedBit << 16].
((self longAt: oop) bitAnd: unusedBit) = 0
ifFalse: [ self error: 'unused header bit 30 is set; should be zero'. ^false ].
"xxx
((self longAt: oop) bitAnd: MarkBit) = 0
ifFalse: [ self error: 'mark bit should not be set except during GC' ].
xxx"
((self isYoungRoot: oop) and: [oop >= youngStart])
ifTrue: [ self error: 'root bit is set in a young object'. ^false ].
^true
!
Item was changed:
----- Method: ObjectMemory>>prepareForwardingTableForBecoming:with:twoWay: (in category 'become') -----
prepareForwardingTableForBecoming: array1 with: array2 twoWay: twoWayFlag
"Ensure that there are enough forwarding blocks to
accomodate this become, then prepare forwarding blocks for
the pointer swap. Return true if successful."
"Details: Doing a GC might generate enough space for
forwarding blocks if we're short. However, this is an
uncommon enough case that it is better handled by primitive
fail code at the Smalltalk level."
"Important note on multiple references to same object - since the preparation of
fwdBlocks is NOT idempotent we get VM crashes if the same object is referenced more
than once in such a way as to require multiple fwdBlocks.
oop1 forwardBecome: oop1 is ok since only a single fwdBlock is needed.
oop1 become: oop1 would fail because the second fwdBlock woudl not have the actual object
header but rather the mutated ref to the first fwdBlock.
Further problems can arise with an array1 or array2 that refer multiply to the same
object. This would notbe expected input for programmer writen code but might arise from
automatic usage such as in ImageSegment loading.
To avoid the simple and rather common case of oop1 become*: oop1, we skip such pairs
and simply avoid making fwdBlocks - it is redundant anyway"
| entriesNeeded entriesAvailable fieldOffset oop1 oop2 fwdBlock fwdBlkSize |
+ entriesNeeded := (self lastPointerOf: array1) // self wordSize. "need enough entries for all oops"
- entriesNeeded := (self lastPointerOf: array1) // BytesPerWord. "need enough entries for all oops"
"Note: Forward blocks must be quadword aligned - see fwdTableInit:."
twoWayFlag
ifTrue: ["Double the number of blocks for two-way become"
entriesNeeded := entriesNeeded * 2.
+ fwdBlkSize := self wordSize * 2]
- fwdBlkSize := BytesPerWord * 2]
ifFalse: ["One-way become needs backPointers in fwd blocks."
+ fwdBlkSize := self wordSize * 4].
- fwdBlkSize := BytesPerWord * 4].
entriesAvailable := self fwdTableInit: fwdBlkSize.
entriesAvailable < entriesNeeded
ifTrue: [self initializeMemoryFirstFree: freeBlock.
"re-initialize the free block"
^ false].
fieldOffset := self lastPointerOf: array1.
+ [fieldOffset >= self baseHeaderSize]
- [fieldOffset >= BaseHeaderSize]
whileTrue: [oop1 := self longAt: array1 + fieldOffset.
oop2 := self longAt: array2 + fieldOffset.
"if oop1 == oop2, no need to do any work for this pair.
May still be other entries in the arrays though so keep looking"
oop1 ~= oop2 ifTrue:
[(self hasForwardingBlock: oop1) ifFalse: "Don't allocate multiple forwarding entries for duplicates."
[fwdBlock := self fwdBlockGet: fwdBlkSize.
self
initForwardBlock: fwdBlock
mapping: oop1
to: oop2
withBackPtr: twoWayFlag not].
(twoWayFlag
and: [(self hasForwardingBlock: oop2) not]) ifTrue: "Again don't get confused by duplicates"
["Second block maps oop2 back to oop1 for two-way become"
fwdBlock := self fwdBlockGet: fwdBlkSize.
self
initForwardBlock: fwdBlock
mapping: oop2
to: oop1
withBackPtr: twoWayFlag not]].
+ fieldOffset := fieldOffset - self wordSize].
- fieldOffset := fieldOffset - BytesPerWord].
^ true!
Item was changed:
----- Method: ObjectMemory>>primitiveFailCodeAfterCleanup: (in category 'image segment in/out') -----
primitiveFailCodeAfterCleanup: outPointerArray
"If the storeSegment primitive fails, it must clean up first."
| i lastAddr | "Store nils throughout the outPointer array."
lastAddr := outPointerArray + (self lastPointerOf: outPointerArray).
+ i := outPointerArray + self baseHeaderSize.
- i := outPointerArray + BaseHeaderSize.
[i <= lastAddr] whileTrue:
[self longAt: i put: nilObj.
+ i := i + self wordSize].
- i := i + BytesPerWord].
DoAssertionChecks ifTrue: [self verifyCleanHeaders].
^PrimErrGenericFailure!
Item was changed:
----- Method: ObjectMemory>>remapClassOf: (in category 'gc -- compaction') -----
remapClassOf: oop
"Update the class of the given object, if necessary, using its forwarding table entry."
"Note: Compact classes need not be remapped since the compact class field is just an index into the compact class
table. The header type bits show if this object has a compact class; we needn't look up the oop's real header."
| classHeader classOop newClassOop newClassHeader |
(self headerType: oop) = HeaderTypeShort ifTrue: [^ nil]. "compact classes needn't be mapped"
+ classHeader := self longAt: oop - self wordSize.
- classHeader := self longAt: oop - BytesPerWord.
classOop := classHeader bitAnd: AllButTypeMask.
(self isObjectForwarded: classOop) ifTrue:
[newClassOop := self remappedObj: classOop.
newClassHeader := newClassOop bitOr: (classHeader bitAnd: TypeMask).
+ self longAt: oop - self wordSize put: newClassHeader.
- self longAt: oop - BytesPerWord put: newClassHeader.
"The following ensures that become: into an old object's class makes it a root.
It does nothing during either incremental or full compaction because
oop will never be < youngStart."
((self oop: oop isLessThan: youngStart)
and: [self oop: newClassOop isGreaterThanOrEqualTo: youngStart])
ifTrue: [self beRootWhileForwarding: oop]]!
Item was changed:
----- Method: ObjectMemory>>remapFieldsAndClassOf: (in category 'gc -- compaction') -----
remapFieldsAndClassOf: oop
"Replace all forwarded pointers in this object with their new oops, using the forwarding table. Remap its class as well, if
necessary. "
"Note: The given oop may be forwarded itself, which means that its real header is in its forwarding table entry."
| fieldOffset fieldOop newOop |
<inline: true>
fieldOffset := self lastPointerWhileForwarding: oop.
+ [fieldOffset >= self baseHeaderSize] whileTrue:
- [fieldOffset >= BaseHeaderSize] whileTrue:
[fieldOop := self longAt: oop + fieldOffset.
(self isObjectForwarded: fieldOop) ifTrue:
["update this oop from its forwarding block"
newOop := self remappedObj: fieldOop.
self longAt: oop + fieldOffset put: newOop.
"The following ensures that become: into old object makes it a root.
It does nothing during either incremental or full compaction because
oop will never be < youngStart."
((self oop: oop isLessThan: youngStart)
and: [self oop: newOop isGreaterThanOrEqualTo: youngStart])
ifTrue: [self beRootWhileForwarding: oop]].
+ fieldOffset := fieldOffset - self wordSize].
- fieldOffset := fieldOffset - BytesPerWord].
self remapClassOf: oop!
Item was changed:
----- Method: ObjectMemory>>restoreHeaderOf: (in category 'become') -----
restoreHeaderOf: obj
"Restore the original header of the given obj from its forwarding block."
<inline: true> "for subclasses"
| fwdHeader fwdBlock objHeader |
fwdHeader := self longAt: obj.
fwdBlock := (fwdHeader bitAnd: AllButMarkBitAndTypeMask) << 1.
self assert: (fwdHeader bitAnd: MarkBit) ~= 0.
self assert: (self fwdBlockValid: fwdBlock).
+ objHeader := self longAt: fwdBlock + self wordSize.
- objHeader := self longAt: fwdBlock + BytesPerWord.
self restoreHeaderOf: obj to: objHeader!
Item was changed:
----- Method: ObjectMemory>>restoreHeadersAfterBecoming:with: (in category 'become') -----
restoreHeadersAfterBecoming: list1 with: list2
"Restore the headers of all oops in both lists. Exchange their hash bits so
becoming objects in identity sets and dictionaries doesn't change their
hash value."
"See also prepareForwardingTableForBecoming:with:woWay: for notes
regarding the case
of oop1 = oop2"
| fieldOffset oop1 oop2 hdr1 hdr2 |
fieldOffset := self lastPointerOf: list1.
+ [fieldOffset >= self baseHeaderSize]
- [fieldOffset >= BaseHeaderSize]
whileTrue: [oop1 := self longAt: list1 + fieldOffset.
oop2 := self longAt: list2 + fieldOffset.
oop1 = oop2
ifFalse: [self restoreHeaderOf: oop1.
self restoreHeaderOf: oop2.
"Exchange hash bits of the two objects."
hdr1 := self longAt: oop1.
hdr2 := self longAt: oop2.
self
longAt: oop1
put: ((hdr1 bitAnd: AllButHashBits) bitOr: (hdr2 bitAnd: HashBits)).
self
longAt: oop2
put: ((hdr2 bitAnd: AllButHashBits) bitOr: (hdr1 bitAnd: HashBits))].
+ fieldOffset := fieldOffset - self wordSize]!
- fieldOffset := fieldOffset - BytesPerWord]!
Item was changed:
----- Method: ObjectMemory>>restoreHeadersAfterForwardBecome: (in category 'become') -----
restoreHeadersAfterForwardBecome: copyHashFlag
"Forward become leaves us with no original oops in the
mutated object list, so we must enumerate the (four-word)
forwarding blocks where we have stored backpointers."
"This loop start is copied from fwdTableInit:"
| oop1 fwdBlock oop2 hdr1 hdr2 |
+ fwdBlock := endOfMemory + self baseHeaderSize + 7 bitAnd: WordMask - 7.
- fwdBlock := endOfMemory + BaseHeaderSize + 7 bitAnd: WordMask - 7.
self flag: #Dan. "See flag comment in fwdTableInit: (dtl)"
+ fwdBlock := fwdBlock + (self wordSize*4).
- fwdBlock := fwdBlock + (BytesPerWord*4).
"fwdBlockGet: did a pre-increment"
[self oop: fwdBlock isLessThanOrEqualTo: fwdTableNext
"fwdTableNext points to the last active block"]
whileTrue:
+ [oop1 := self longAt: fwdBlock + (self wordSize*2).
- [oop1 := self longAt: fwdBlock + (BytesPerWord*2).
"Backpointer to mutated object."
oop2 := self longAt: fwdBlock.
self restoreHeaderOf: oop1.
copyHashFlag ifTrue:
"Change the hash of the new oop (oop2) to be that of the old (oop1)
so mutated objects in hash structures will be happy after the change."
[hdr1 := self longAt: oop1.
hdr2 := self longAt: oop2.
self longAt: oop2 put: ((hdr2 bitAnd: AllButHashBits) bitOr: (hdr1 bitAnd: HashBits))].
"Free the old object so it won't resurface through e.g. alInstances or allObjects."
self freeObject: oop1.
+ fwdBlock := fwdBlock + (self wordSize*4)]!
- fwdBlock := fwdBlock + (BytesPerWord*4)]!
Item was changed:
----- Method: ObjectMemory>>restoreHeadersFrom:to:from:and:to:from: (in category 'image segment in/out') -----
restoreHeadersFrom: firstIn to: lastIn from: hdrBaseIn and: firstOut to: lastOut from: hdrBaseOut
"Restore headers smashed by forwarding links"
| tablePtr oop header |
tablePtr := firstIn.
[self oop: tablePtr isLessThanOrEqualTo: lastIn] whileTrue:
[oop := self longAt: tablePtr.
header := self longAt: hdrBaseIn + (tablePtr-firstIn).
self longAt: oop put: header.
+ tablePtr := tablePtr + self wordSize].
- tablePtr := tablePtr + BytesPerWord].
tablePtr := firstOut.
[self oop: tablePtr isLessThanOrEqualTo: lastOut] whileTrue:
[oop := self longAt: tablePtr.
header := self longAt: hdrBaseOut + (tablePtr-firstOut).
self longAt: oop put: header.
+ tablePtr := tablePtr + self wordSize].
- tablePtr := tablePtr + BytesPerWord].
"Clear all mark bits"
oop := self firstObject.
[self oop: oop isLessThan: endOfMemory] whileTrue:
[(self isFreeObject: oop) ifFalse:
[self longAt: oop put: ((self longAt: oop) bitAnd: AllButMarkBit)].
oop := self objectAfter: oop]!
Item was changed:
----- Method: ObjectMemory>>reverseBytesFrom:to: (in category 'image save/restore') -----
reverseBytesFrom: startAddr to: stopAddr
"Byte-swap the given range of memory (not inclusive of stopAddr!!)."
| addr |
addr := startAddr.
[self oop: addr isLessThan: stopAddr] whileTrue:
[self longAt: addr put: (self byteSwapped: (self longAt: addr)).
+ addr := addr + self wordSize].!
- addr := addr + BytesPerWord].!
Item was changed:
----- Method: ObjectMemory>>reverseWordsFrom:to: (in category 'image save/restore') -----
reverseWordsFrom: startAddr to: stopAddr
"Word-swap the given range of memory, excluding stopAddr."
| addr |
addr := startAddr.
[self oop: addr isLessThan: stopAddr] whileTrue:
[self longAt: addr put: (self wordSwapped: (self longAt: addr)).
+ addr := addr + self wordSize].!
- addr := addr + BytesPerWord].!
Item was changed:
----- Method: ObjectMemory>>safePrintStringOf: (in category 'debug printing') -----
safePrintStringOf: oop
"Version of printStringOf: that copes with forwarding during garbage collection."
| fmt header cnt i |
<inline: false>
(self isIntegerObject: oop) ifTrue:
[^nil].
(self oop: oop isGreaterThanOrEqualTo: self startOfMemory andLessThan: freeBlock) ifFalse:
[^nil].
+ (oop bitAnd: (self wordSize - 1)) ~= 0 ifTrue:
- (oop bitAnd: (BytesPerWord - 1)) ~= 0 ifTrue:
[^nil].
header := self headerWhileForwardingOf: oop.
fmt := self formatOfHeader: header.
fmt < self firstByteFormat ifTrue: [^nil].
cnt := 100 min: (self lengthOf: oop baseHeader: header format: fmt).
i := 0.
[i < cnt] whileTrue:
[self printChar: (self fetchByte: i ofObject: oop).
i := i + 1].
self flush.
^oop!
Item was changed:
----- Method: ObjectMemory>>setEndOfMemory: (in category 'initialization') -----
setEndOfMemory: newEndOfMemory
+ self assert: (newEndOfMemory bitAnd: self wordSize - 1) = 0.
- self assert: (newEndOfMemory bitAnd: BytesPerWord - 1) = 0.
endOfMemory := newEndOfMemory!
Item was changed:
----- Method: ObjectMemory>>setMemoryLimit: (in category 'initialization') -----
setMemoryLimit: newMemoryLimit
+ self assert: (newMemoryLimit bitAnd: self wordSize - 1) = 0.
- self assert: (newMemoryLimit bitAnd: BytesPerWord - 1) = 0.
memoryLimit := newMemoryLimit!
Item was added:
+ ----- Method: ObjectMemory>>shiftForWord (in category 'interpreter access') -----
+ shiftForWord
+ "N.B. This would appear to hard-code the header size for 32-bit images. But if generating
+ a 64-bit image, this method could be removed and the relevant one substituted. We can't
+ mark this method as <doNotGenerate> as we need an actual method to guide code gen."
+ ^2!
Item was changed:
----- Method: ObjectMemory>>shorten:toIndexableSize: (in category 'allocation') -----
shorten: obj toIndexableSize: nSlots
"Reduce the number of indexable fields in obj, a pointer object, to nSlots. Convert the
unused residual to a free chunk. Word and byte indexable objects are not changed.
Answer the number of bytes returned to free memory, which may be zero if no change
was possible."
| deltaBytes desiredLength fixedFields fmt hdr totalLength
indexableFields |
(self isPointersNonImm: obj) ifFalse: [^0].
nSlots > 0
ifFalse: [^0]. "no change if nSlots is zero, error if nSlots is negative"
hdr := self baseHeader: obj.
fmt := self formatOfHeader: hdr.
totalLength := self lengthOf: obj baseHeader: hdr format: fmt.
fixedFields := self fixedFieldsOf: obj format: fmt length: totalLength.
indexableFields := totalLength - fixedFields.
nSlots >= indexableFields
ifTrue: [^0]. "no change, or error if attempting to increase size into next chunk"
desiredLength := fixedFields + nSlots.
+ deltaBytes := (totalLength - desiredLength) * self wordSize.
+ self setSizeOfFree: obj + self baseHeaderSize + (desiredLength * self wordSize)
- deltaBytes := (totalLength - desiredLength) * BytesPerWord.
- self setSizeOfFree: obj + BaseHeaderSize + (desiredLength * BytesPerWord)
to: deltaBytes.
(self headerType: obj) caseOf: {
[HeaderTypeSizeAndClass] ->
+ [self longAt: (obj - (self baseHeaderSize * 2)) put: (self sizeHeader: obj) - deltaBytes].
- [self longAt: (obj - (BaseHeaderSize * 2)) put: (self sizeHeader: obj) - deltaBytes].
[HeaderTypeClass] ->
[self longAt: obj put: ((hdr bitClear: SizeMask) bitOr: (hdr bitAnd: SizeMask) - deltaBytes)].
[HeaderTypeShort] ->
[self longAt: obj put: ((hdr bitClear: SizeMask) bitOr: (hdr bitAnd: SizeMask) - deltaBytes)] }.
^deltaBytes!
Item was changed:
----- Method: ObjectMemory>>sizeHeader: (in category 'header access') -----
sizeHeader: oop
+ ^ self longAt: oop - (self wordSize*2)!
- ^ self longAt: oop - (BytesPerWord*2)!
Item was changed:
+ ----- Method: ObjectMemory>>splObj: (in category 'accessing') -----
- ----- Method: ObjectMemory>>splObj: (in category 'interpreter access') -----
splObj: index
<api>
<inline: true>
"Return one of the objects in the SpecialObjectsArray"
^self fetchPointer: index ofObject: specialObjectsOop!
Item was changed:
----- Method: ObjectMemory>>startField (in category 'gc -- mark and sweep') -----
startField
"Examine and possibly trace the next field of the object being
traced. See comment in markAndTrace for explanation of
tracer state variables, and aComment for gory details."
| typeBits childType |
<inline: true>
[child := self longAt: field.
self isIntegerObject: child] whileTrue:
["field contains a SmallInteger; skip it"
+ field := field - self wordSize.
- field := field - BytesPerWord.
"Effectively ^ StartField"].
typeBits := child bitAnd: TypeMask.
typeBits = 0 ifTrue: "normal oop, go down"
[self longAt: field put: parentField.
parentField := field.
^ StartObj].
self assert: typeBits = 2.
"reached the header; do we need to process the class word? "
(child bitAnd: CompactClassMask) ~= 0 ifTrue:
["object's class is compact; we're done"
"restore the header type bits"
child := child bitAnd: AllButTypeMask.
childType := self rightType: child.
self longAt: field put: (child bitOr: childType).
^ Upward].
"object has a full class word; process that class"
+ child := self longAt: field - self wordSize. "class word"
- child := self longAt: field - BytesPerWord. "class word"
child := child bitAnd: AllButTypeMask. "clear type bits"
+ self longAt: field - self wordSize put: parentField.
+ parentField := field - self wordSize bitOr: 1.
- self longAt: field - BytesPerWord put: parentField.
- parentField := field - BytesPerWord bitOr: 1.
"point at class word; mark as working on the class. "
^ StartObj!
Item was changed:
----- Method: ObjectMemory>>storeByte:ofObject:withValue: (in category 'object access') -----
storeByte: byteIndex ofObject: oop withValue: valueByte
+ ^ self byteAt: oop + self baseHeaderSize + byteIndex
- ^ self byteAt: oop + BaseHeaderSize + byteIndex
put: valueByte!
Item was changed:
----- Method: ObjectMemory>>storeImageSegmentInto:outPointers:roots: (in category 'image segment in/out') -----
storeImageSegmentInto: segmentWordArray outPointers: outPointerArray roots: arrayOfRoots
"This primitive will store a binary image segment (in the same format as the Squeak image file) of the receiver and every object in its proper tree of subParts (ie, that is not refered to from anywhere else outside the tree). All pointers from within the tree to objects outside the tree will be copied into the array of outpointers. In their place in the image segment will be an oop equal to the offset in the outPointer array (the first would be 4). but with the high bit set."
"The primitive expects the array and wordArray to be more than adequately long. In this case it returns normally, and truncates the two arrays to exactly the right size. To simplify truncation, both incoming arrays are required to be 256 bytes or more long (ie with 3-word headers). If either array is too small, the primitive will fail, but in no other case.
During operation of the primitive, it is necessary to convert from both internal and external oops to their mapped values. To make this fast, the headers of the original objects in question are replaced by the mapped values (and this is noted by adding the forbidden XX header type). Tables are kept of both kinds of oops, as well as of the original headers for restoration.
To be specific, there are two similar two-part tables, the outpointer array, and one in the upper fifth of the segmentWordArray. Each grows oops from the bottom up, and preserved headers from halfway up.
In case of either success or failure, the headers must be restored. In the event of primitive failure, the table of outpointers must also be nilled out (since the garbage in the high half will not have been discarded."
| savedYoungStart lastOut lastIn firstIn lastSeg endSeg segOop fieldPtr fieldOop mapOop
doingClass lastPtr extraSize hdrTypeBits hdrBaseIn hdrBaseOut header firstOut versionOffset |
<inline: false>
<var: #firstIn type: #usqInt>
<var: #lastIn type: #usqInt>
<var: #firstOut type: #usqInt>
<var: #lastOut type: #usqInt>
<var: #hdrBaseIn type: #usqInt>
<var: #hdrBaseOut type: #usqInt>
<var: #lastSeg type: #usqInt>
<var: #endSeg type: #usqInt>
<var: #fieldPtr type: #usqInt>
<var: #lastPtr type: #usqInt>
<var: #segOop type: #usqInt>
<var: #savedYoungStart type: #usqInt>
((self headerType: outPointerArray) = HeaderTypeSizeAndClass "Must be 3-word header"
and: [(self headerType: segmentWordArray) = HeaderTypeSizeAndClass]) "Must be 3-word header"
ifFalse: [^PrimErrGenericFailure].
DoAssertionChecks ifTrue: [self verifyCleanHeaders].
"Use the top half of outPointers for saved headers."
+ firstOut := outPointerArray + self baseHeaderSize.
+ lastOut := firstOut - self wordSize.
+ hdrBaseOut := outPointerArray + ((self lastPointerOf: outPointerArray) // (self wordSize*2) * self wordSize). "top half"
- firstOut := outPointerArray + BaseHeaderSize.
- lastOut := firstOut - BytesPerWord.
- hdrBaseOut := outPointerArray + ((self lastPointerOf: outPointerArray) // (BytesPerWord*2) * BytesPerWord). "top half"
lastSeg := segmentWordArray.
+ endSeg := segmentWordArray + (self sizeBitsOf: segmentWordArray) - self wordSize.
- endSeg := segmentWordArray + (self sizeBitsOf: segmentWordArray) - BytesPerWord.
"Write a version number for byte order and version check"
+ versionOffset := self wordSize.
- versionOffset := BytesPerWord.
lastSeg := lastSeg + versionOffset.
lastSeg > endSeg ifTrue: [^PrimErrGenericFailure].
self longAt: lastSeg put: self imageSegmentVersion.
"Allocate top 1/8 of segment for table of internal oops and saved headers"
+ firstIn := endSeg - ((self sizeBitsOf: segmentWordArray) // (self wordSize*8) * self wordSize). "Take 1/8 of seg"
+ lastIn := firstIn - self wordSize.
+ hdrBaseIn := firstIn + ((self sizeBitsOf: segmentWordArray) // (self wordSize*16) * self wordSize). "top half of that"
- firstIn := endSeg - ((self sizeBitsOf: segmentWordArray) // (BytesPerWord*8) * BytesPerWord). "Take 1/8 of seg"
- lastIn := firstIn - BytesPerWord.
- hdrBaseIn := firstIn + ((self sizeBitsOf: segmentWordArray) // (BytesPerWord*16) * BytesPerWord). "top half of that"
"First mark the rootArray and all root objects."
self longAt: arrayOfRoots put: ((self longAt: arrayOfRoots) bitOr: MarkBit).
lastPtr := arrayOfRoots + (self lastPointerOf: arrayOfRoots).
+ fieldPtr := arrayOfRoots + self baseHeaderSize.
- fieldPtr := arrayOfRoots + BaseHeaderSize.
[fieldPtr <= lastPtr] whileTrue:
[fieldOop := self longAt: fieldPtr.
(self isIntegerObject: fieldOop) ifFalse:
[self longAt: fieldOop put: ((self longAt: fieldOop) bitOr: MarkBit)].
+ fieldPtr := fieldPtr + self wordSize].
- fieldPtr := fieldPtr + BytesPerWord].
"Then do a mark pass over all objects. This will stop at our marked roots,
thus leaving our segment unmarked in their shadow."
savedYoungStart := youngStart.
youngStart := self startOfMemory. "process all of memory"
self markAndTraceInterpreterOops. "and special objects array"
youngStart := savedYoungStart.
"Finally unmark the rootArray and all root objects."
self longAt: arrayOfRoots put: ((self longAt: arrayOfRoots) bitAnd: AllButMarkBit).
+ fieldPtr := arrayOfRoots + self baseHeaderSize.
- fieldPtr := arrayOfRoots + BaseHeaderSize.
[fieldPtr <= lastPtr] whileTrue:
[fieldOop := self longAt: fieldPtr.
(self isIntegerObject: fieldOop) ifFalse:
[self longAt: fieldOop put: ((self longAt: fieldOop) bitAnd: AllButMarkBit)].
+ fieldPtr := fieldPtr + self wordSize].
- fieldPtr := fieldPtr + BytesPerWord].
"All external objects, and only they, are now marked.
Copy the array of roots into the segment, and forward its oop."
+ lastIn := lastIn + self wordSize.
- lastIn := lastIn + BytesPerWord.
(lastIn >= hdrBaseIn
or: [0 = (lastSeg := self copyObj: arrayOfRoots toSegment: segmentWordArray addr: lastSeg stopAt: firstIn saveOopAt: lastIn headerAt: hdrBaseIn + (lastIn - firstIn))]) ifTrue:
+ [lastIn := lastIn - self wordSize.
- [lastIn := lastIn - BytesPerWord.
self restoreHeadersFrom: firstIn to: lastIn from: hdrBaseIn and: firstOut to: lastOut from: hdrBaseOut.
^self primitiveFailCodeAfterCleanup: outPointerArray].
"Now run through the segment fixing up all the pointers.
Note that more objects will be added to the segment as we make our way along."
+ segOop := self oopFromChunk: segmentWordArray + versionOffset + self baseHeaderSize.
- segOop := self oopFromChunk: segmentWordArray + versionOffset + BaseHeaderSize.
[segOop <= lastSeg] whileTrue:
[(self headerType: segOop) <= 1
ifTrue: ["This object has a class field (type=0 or 1) -- start with that."
+ fieldPtr := segOop - self wordSize. doingClass := true]
- fieldPtr := segOop - BytesPerWord. doingClass := true]
ifFalse: ["No class field -- start with first data field"
+ fieldPtr := segOop + self baseHeaderSize. doingClass := false].
- fieldPtr := segOop + BaseHeaderSize. doingClass := false].
lastPtr := segOop + (self lastPointerOf: segOop). "last field"
"Go through all oops, remapping them..."
[fieldPtr > lastPtr] whileFalse:
["Examine each pointer field"
fieldOop := self longAt: fieldPtr.
doingClass ifTrue:
[hdrTypeBits := fieldOop bitAnd: TypeMask.
fieldOop := fieldOop - hdrTypeBits].
(self isIntegerObject: fieldOop)
ifTrue: ["Just an integer -- nothing to do"
+ fieldPtr := fieldPtr + self wordSize]
- fieldPtr := fieldPtr + BytesPerWord]
ifFalse:
[header := self longAt: fieldOop.
(header bitAnd: TypeMask) = HeaderTypeFree
ifTrue: ["Has already been forwarded -- this is the link"
mapOop := header bitAnd: AllButTypeMask]
ifFalse:
[((self longAt: fieldOop) bitAnd: MarkBit) = 0
ifTrue:
["Points to an unmarked obj -- an internal pointer.
Copy the object into the segment, and forward its oop."
+ lastIn := lastIn + self wordSize.
- lastIn := lastIn + BytesPerWord.
(lastIn >= hdrBaseIn
or: [0 = (lastSeg := self copyObj: fieldOop toSegment: segmentWordArray addr: lastSeg stopAt: firstIn saveOopAt: lastIn headerAt: hdrBaseIn + (lastIn - firstIn))]) ifTrue:
["Out of space in segment"
+ lastIn := lastIn - self wordSize.
- lastIn := lastIn - BytesPerWord.
self restoreHeadersFrom: firstIn to: lastIn from: hdrBaseIn and: firstOut to: lastOut from: hdrBaseOut.
^self primitiveFailCodeAfterCleanup: outPointerArray].
mapOop := (self longAt: fieldOop) bitAnd: AllButTypeMask]
ifFalse:
["Points to a marked obj -- an external pointer.
Map it as a tagged index in outPointers, and forward its oop."
+ lastOut := lastOut + self wordSize.
- lastOut := lastOut + BytesPerWord.
lastOut >= hdrBaseOut ifTrue:
["Out of space in outPointerArray"
+ lastOut := lastOut - self wordSize.
- lastOut := lastOut - BytesPerWord.
self restoreHeadersFrom: firstIn to: lastIn from: hdrBaseIn and: firstOut to: lastOut from: hdrBaseOut.
^self primitiveFailCodeAfterCleanup: outPointerArray].
. mapOop := lastOut - outPointerArray bitOr: 16r80000000.
self forward: fieldOop to: mapOop
savingOopAt: lastOut andHeaderAt: hdrBaseOut + (lastOut - firstOut)]].
"Replace the oop by its mapped value"
doingClass
ifTrue: [self longAt: fieldPtr put: mapOop + hdrTypeBits.
+ fieldPtr := fieldPtr + (self wordSize*2).
- fieldPtr := fieldPtr + (BytesPerWord*2).
doingClass := false]
ifFalse: [self longAt: fieldPtr put: mapOop.
+ fieldPtr := fieldPtr + self wordSize]]].
- fieldPtr := fieldPtr + BytesPerWord]]].
segOop := self objectAfter: segOop].
self restoreHeadersFrom: firstIn to: lastIn from: hdrBaseIn and: firstOut to: lastOut from: hdrBaseOut.
"Truncate the outPointerArray..."
((outPointerArray + (self lastPointerOf: outPointerArray) - lastOut) < 12
or: [(endSeg - lastSeg) < 12]) ifTrue:
["Not enough room to insert simple 3-word headers"
^self primitiveFailCodeAfterCleanup: outPointerArray].
extraSize := self extraHeaderBytes: segmentWordArray.
hdrTypeBits := self headerType: segmentWordArray.
"Copy the 3-word wordArray header to establish a free chunk."
self transfer: 3
from: segmentWordArray - extraSize
+ to: lastOut+self wordSize.
- to: lastOut+BytesPerWord.
"Adjust the size of the original as well as the free chunk."
+ self longAt: lastOut+self wordSize
- self longAt: lastOut+BytesPerWord
put: outPointerArray + (self lastPointerOf: outPointerArray) - lastOut - extraSize + hdrTypeBits.
self longAt: outPointerArray-extraSize
+ put: lastOut - firstOut + (self wordSize*2) + hdrTypeBits.
- put: lastOut - firstOut + (BytesPerWord*2) + hdrTypeBits.
"Note that pointers have been stored into roots table"
self beRootIfOld: outPointerArray.
"Truncate the image segment..."
"Copy the 3-word wordArray header to establish a free chunk."
self transfer: 3
from: segmentWordArray - extraSize
+ to: lastSeg+self wordSize.
- to: lastSeg+BytesPerWord.
"Adjust the size of the original as well as the free chunk."
self longAt: segmentWordArray-extraSize
+ put: lastSeg - segmentWordArray + self baseHeaderSize + hdrTypeBits.
+ self longAt: lastSeg+self wordSize
- put: lastSeg - segmentWordArray + BaseHeaderSize + hdrTypeBits.
- self longAt: lastSeg+BytesPerWord
put: endSeg - lastSeg - extraSize + hdrTypeBits.
DoAssertionChecks ifTrue: [self verifyCleanHeaders].
^PrimNoErr!
Item was changed:
----- Method: ObjectMemory>>storeLong32:ofObject:withValue: (in category 'object access') -----
storeLong32: fieldIndex ofObject: oop withValue: valueWord
+ ^ self long32At: oop + self baseHeaderSize + (fieldIndex << 2)
- ^ self long32At: oop + BaseHeaderSize + (fieldIndex << 2)
put: valueWord!
Item was changed:
----- Method: ObjectMemory>>storeLong64:ofObject:withValue: (in category 'object access') -----
storeLong64: longIndex ofObject: oop withValue: value
<var: #value type: #sqLong>
+ ^self long64At: oop + self baseHeaderSize + (longIndex << 3) put: value!
- ^self long64At: oop + BaseHeaderSize + (longIndex << 3) put: value!
Item was changed:
----- Method: ObjectMemory>>storePointer:ofObject:withValue: (in category 'object access') -----
storePointer: fieldIndex ofObject: oop withValue: valuePointer
"Note must check here for stores of young objects into old ones."
(self oop: oop isLessThan: youngStart) ifTrue: [
self possibleRootStoreInto: oop value: valuePointer.
].
+ ^ self longAt: oop + self baseHeaderSize + (fieldIndex << self shiftForWord)
- ^ self longAt: oop + BaseHeaderSize + (fieldIndex << ShiftForWord)
put: valuePointer!
Item was changed:
----- Method: ObjectMemory>>storePointerUnchecked:ofObject:withValue: (in category 'object access') -----
storePointerUnchecked: fieldIndex ofObject: oop withValue: valuePointer
"Like storePointer:ofObject:withValue:, but the caller guarantees that the
object being stored into is a young object or is already marked as a root."
<api>
<inline: true>
^self
+ longAt: oop + self baseHeaderSize + (fieldIndex << self shiftForWord)
- longAt: oop + BaseHeaderSize + (fieldIndex << ShiftForWord)
put: valuePointer!
Item was changed:
----- Method: ObjectMemory>>storeShort16:ofObject:withValue: (in category 'object access') -----
storeShort16: shortIndex ofObject: objOop withValue: value
^self
+ shortAt: objOop + self baseHeaderSize + (shortIndex << 1)
- shortAt: objOop + BaseHeaderSize + (shortIndex << 1)
put: (self cCode: [value] inSmalltalk: [value bitAnd: 16rFFFF])!
Item was changed:
----- Method: ObjectMemory>>sufficientSpaceToAllocate: (in category 'allocation') -----
sufficientSpaceToAllocate: bytes
"Return true if there is enough space to allocate the given number of bytes, perhaps after doing a garbage collection."
| minFree |
<inline: true>
+ minFree := (lowSpaceThreshold + bytes + self baseHeaderSize + self wordSize - 1) bitClear: self wordSize - 1.
- minFree := (lowSpaceThreshold + bytes + BaseHeaderSize + BytesPerWord - 1) bitClear: BytesPerWord - 1.
"check for low-space"
(self oop: (self sizeOfFree: freeBlock) isGreaterThanOrEqualTo: minFree)
ifTrue: [^true]
ifFalse: [^self sufficientSpaceAfterGC: minFree].!
Item was changed:
----- Method: ObjectMemory>>sufficientSpaceToInstantiate:indexableSize: (in category 'allocation') -----
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."
<var: #size type: #usqInt>
| format allocSize |
<inline: true>
(format := self instSpecOfClass: classOop) < self firstByteFormat
ifTrue:
["indexable fields are words or pointers"
size ~= 0 ifTrue:
["fail if attempting to call new: on non-indexable class"
format < self arrayFormat ifTrue:
[^false].
"fail if attempting to allocate over 2 Gb, since this overflows 32-bit arithmetic"
+ size >> (LongSizeNumBits - self shiftForWord) > 0 ifTrue:
- size >> (LongSizeNumBits - ShiftForWord) > 0 ifTrue:
[^false]].
+ allocSize := size * self wordSize]
- allocSize := size * BytesPerWord]
ifFalse:
["indexable fields are bytes"
"fail if attempting to allocate over 2 Gb, since this overflows 32-bit arithmetic"
size >> LongSizeNumBits > 0 ifTrue:
[^false].
allocSize := size].
^self sufficientSpaceToAllocate: 2500 + allocSize!
Item was changed:
----- Method: ObjectMemory>>sweepPhase (in category 'gc -- mark and sweep') -----
sweepPhase
"Sweep memory from youngStart through the end of memory. Free all
inaccessible objects and coalesce adjacent free chunks. Clear the mark
bits of accessible objects. Compute the starting point for the first pass of
incremental compaction (compStart). Return the number of surviving
objects. "
"Details: Each time a non-free object is encountered, decrement the
number of available forward table entries. If all entries are spoken for
(i.e., entriesAvailable reaches zero), set compStart to the last free
chunk before that object or, if there is no free chunk before the given
object, the first free chunk after it. Thus, at the end of the sweep
phase, compStart through compEnd spans the highest collection of
non-free objects that can be accomodated by the forwarding table. This
information is used by the first pass of incremental compaction to
ensure that space is initially freed at the end of memory. Note that
there should always be at least one free chunk--the one at the end of
the heap."
| entriesAvailable survivors freeChunk firstFree oop oopHeader oopHeaderType hdrBytes oopSize freeChunkSize endOfMemoryLocal |
<inline: false>
<var: #oop type: 'usqInt'>
<var: #endOfMemoryLocal type: 'usqInt'>
+ entriesAvailable := self fwdTableInit: self wordSize*2.
- entriesAvailable := self fwdTableInit: BytesPerWord*2.
survivors := 0.
freeChunk := nil.
firstFree := nil.
"will be updated later"
endOfMemoryLocal := endOfMemory.
oop := self oopFromChunk: youngStart.
[oop < endOfMemoryLocal]
whileTrue: ["get oop's header, header type, size, and header size"
statSweepCount := statSweepCount + 1.
oopHeader := self baseHeader: oop.
oopHeaderType := oopHeader bitAnd: TypeMask.
hdrBytes := headerTypeBytes at: oopHeaderType.
(oopHeaderType bitAnd: 1) = 1
ifTrue: [oopSize := oopHeader bitAnd: SizeMask]
ifFalse: [oopHeaderType = HeaderTypeSizeAndClass
ifTrue: [oopSize := (self sizeHeader: oop) bitAnd: LongSizeMask]
ifFalse: ["free chunk" oopSize := oopHeader bitAnd: LongSizeMask]].
(oopHeader bitAnd: MarkBit) = 0
ifTrue: ["object is not marked; free it"
"<-- Finalization support: We need to mark each oop chunk as free -->"
self longAt: oop - hdrBytes put: HeaderTypeFree.
freeChunk ~= nil
ifTrue: ["enlarge current free chunk to include this oop"
freeChunkSize := freeChunkSize + oopSize + hdrBytes]
ifFalse: ["start a new free chunk"
freeChunk := oop - hdrBytes.
"chunk may start 4 or 8 bytes before oop"
freeChunkSize := oopSize + (oop - freeChunk).
"adjust size for possible extra header bytes"
firstFree = nil ifTrue: [firstFree := freeChunk]]]
ifFalse: ["object is marked; clear its mark bit and possibly adjust
the compaction start"
self longAt: oop put: (oopHeader bitAnd: AllButMarkBit).
"<-- Finalization support: Check if we're running about a weak class -->"
(self isWeakNonImm: oop) ifTrue: [self finalizeReference: oop].
entriesAvailable > 0
ifTrue: [entriesAvailable := entriesAvailable - 1]
ifFalse: ["start compaction at the last free chunk before this object"
firstFree := freeChunk].
freeChunk ~= nil
ifTrue: ["record the size of the last free chunk"
self longAt: freeChunk put: ((freeChunkSize bitAnd: LongSizeMask) bitOr: HeaderTypeFree).
freeChunk := nil].
survivors := survivors + 1].
oop := self oopFromChunk: oop + oopSize].
freeChunk ~= nil
ifTrue: ["record size of final free chunk"
self longAt: freeChunk put: ((freeChunkSize bitAnd: LongSizeMask) bitOr: HeaderTypeFree)].
oop = endOfMemory
ifFalse: [self error: 'sweep failed to find exact end of memory'].
firstFree = nil
ifTrue: [self error: 'expected to find at least one free object']
ifFalse: [compStart := firstFree].
^ survivors!
Item was changed:
----- Method: ObjectMemory>>transfer:from:to: (in category 'utilities') -----
transfer: count from: src to: dst
| in out lastIn |
<inline: true>
self flag: #Dan. "Need to check all senders before converting this for 64 bits"
+ in := src - self wordSize.
+ lastIn := in + (count * self wordSize).
+ out := dst - self wordSize.
- in := src - BytesPerWord.
- lastIn := in + (count * BytesPerWord).
- out := dst - BytesPerWord.
[self oop: in isLessThan: lastIn]
whileTrue: [self
+ longAt: (out := out + self wordSize)
+ put: (self longAt: (in := in + self wordSize))]!
- longAt: (out := out + BytesPerWord)
- put: (self longAt: (in := in + BytesPerWord))]!
Item was added:
+ ----- Method: ObjectMemory>>unsignedIntegerSuffix (in category 'as yet unclassified') -----
+ unsignedIntegerSuffix
+ "Answer the suffix that should be appended to unsigned integer literals in generated code."
+
+ ^self wordSize = 4 ifTrue: ['UL'] ifFalse: ['ULL']!
Item was changed:
----- Method: ObjectMemory>>upward (in category 'gc -- mark and sweep') -----
upward
"Return from marking an object below. Incoming:
field = oop we just worked on, needs to be put away
parentField = where to put it in our object
NOTE: Type field of object below has already been restored!!!!!!
See comment in markAndTrace for explanation of
tracer state variables, and aComment for gory details."
| type header |
<inline: true>
[(parentField bitAnd: 1) = 0 ifTrue:
["normal"
child := field. "who we worked on below"
field := parentField. "where to put it"
parentField := self longAt: field.
self longAt: field put: child.
+ field := field - self wordSize. "point at header"
- field := field - BytesPerWord. "point at header"
^ StartField].
parentField = GCTopMarker ifTrue:
["top of the chain"
header := (self longAt: field) bitAnd: AllButTypeMask.
type := self rightType: header.
self longAt: field put: (header bitOr: type). "install type on class oop"
^ Done].
"was working on the extended class word"
child := field. "oop of class"
field := parentField - 1. "class word, ** clear the low bit **"
parentField := self longAt: field.
+ header := self longAt: field + self wordSize. "base header word"
- header := self longAt: field + BytesPerWord. "base header word"
type := self rightType: header.
self longAt: field put: (child bitOr: type). "install type on class oop"
+ field := field + self wordSize. "point at header"
- field := field + BytesPerWord. "point at header"
"restore type bits"
header := header bitAnd: AllButTypeMask.
self longAt: field put: (header bitOr: type).
"Effectively ^ Upward"
true] whileTrue.
^nil "for Slang..."!
Item was changed:
----- Method: ObjectMemory>>validate: (in category 'simulation') -----
validate: oop
<doNotGenerate>
| header type cc sz fmt nextChunk |
header := self longAt: oop.
type := header bitAnd: 3.
type = 2 ifFalse: [type = (self rightType: header) ifFalse: [self halt]].
sz := (header bitAnd: SizeMask) >> 2.
(self isFreeObject: oop)
ifTrue: [ nextChunk := oop + (self sizeOfFree: oop) ]
ifFalse: [ nextChunk := oop + (self sizeBitsOf: oop) ].
nextChunk > endOfMemory
ifTrue: [oop = endOfMemory ifFalse: [self halt]].
(self headerType: nextChunk) = 0 ifTrue: [
+ (self headerType: (nextChunk + (self wordSize*2))) = 0 ifFalse: [self halt]].
- (self headerType: (nextChunk + (BytesPerWord*2))) = 0 ifFalse: [self halt]].
(self headerType: nextChunk) = 1 ifTrue: [
+ (self headerType: (nextChunk + self wordSize)) = 1 ifFalse: [self halt]].
- (self headerType: (nextChunk + BytesPerWord)) = 1 ifFalse: [self halt]].
type = 2 ifTrue:
["free block" ^ self].
fmt := self formatOfHeader: header.
cc := self compactClassIndexOfHeader: header.
cc > 16 ifTrue: [self halt]. "up to 32 are legal, but not used"
type = 0 ifTrue:
["three-word header"
+ ((self longAt: oop-self wordSize) bitAnd: 3) = type ifFalse: [self halt].
+ ((self longAt: oop-(self wordSize*2)) bitAnd: 3) = type ifFalse: [self halt].
+ ((self longAt: oop-self wordSize) = type) ifTrue: [self halt]. "Class word is 0"
- ((self longAt: oop-BytesPerWord) bitAnd: 3) = type ifFalse: [self halt].
- ((self longAt: oop-(BytesPerWord*2)) bitAnd: 3) = type ifFalse: [self halt].
- ((self longAt: oop-BytesPerWord) = type) ifTrue: [self halt]. "Class word is 0"
sz = 0 ifFalse: [self halt]].
type = 1 ifTrue:
["two-word header"
+ ((self longAt: oop-self wordSize) bitAnd: 3) = type ifFalse: [self halt].
- ((self longAt: oop-BytesPerWord) bitAnd: 3) = type ifFalse: [self halt].
cc > 0 ifTrue: [sz = 1 ifFalse: [self halt]].
sz = 0 ifTrue: [self halt]].
type = 3 ifTrue:
["one-word header"
cc = 0 ifTrue: [self halt]].
fmt = 5 ifTrue: [self halt].
fmt = 7 ifTrue: [self halt].
fmt >= self firstCompiledMethodFormat ifTrue: "must have integer header"
+ [(self isIntegerObject: (self longAt: oop + self wordSize)) ifFalse: [self halt]].!
- [(self isIntegerObject: (self longAt: oop + BytesPerWord)) ifFalse: [self halt]].!
Item was changed:
----- Method: ObjectMemory>>weakFinalizerCheck: (in category 'finalization') -----
weakFinalizerCheck: oop
"Our oop has at least 2 non-weak fixed slots (this is assured before entering this method, in
#finalizeReference:.
We are assuming that if its first non-weak field is an instance of ClassWeakFinalizationList class,
then we should add this oop to that list, by storing it to list's first field and
also, updating the oop's 2nd fixed slot to point to the value which we overridden:
list := oop instVarAt: 1.
list class == WeakFinalizationList ifTrue: [
first := list instVarAt: 1.
oop instVarAt: 2 put: first.
list instVarAt: 1 put: oop ] "
<inline: true>
- <asmLabel: false> "prevent label duplication"
| listOop listItemOop |
listOop := self fetchPointer: 0 ofObject: oop.
(self fetchClassOf: listOop) = (self splObj: ClassWeakFinalizer) ifTrue:
[listItemOop := self fetchPointer: 0 ofObject: listOop.
self storePointer: 1 ofObject: oop withValue: listItemOop.
+ self storePointer: 0 ofObject: listOop withValue: oop]!
- self storePointer: 0 ofObject: listOop withValue: oop]
- !
Item was changed:
+ ----- Method: ObjectMemory>>wordSize (in category 'interpreter access') -----
- ----- Method: ObjectMemory>>wordSize (in category 'initialization') -----
wordSize
+ "Answer the width of an object pointer, in bytes."
- "Answer the size of an object pointer in bytes."
+ ^self wordSize!
- ^4!
Item was changed:
----- Method: SimpleStackBasedCogit>>compileInterpreterPrimitive: (in category 'primitive generators') -----
compileInterpreterPrimitive: primitiveRoutine
"Compile a call to an interpreter primitive. Call the C routine with the
usual stack-switching dance, test the primFailCode and then either
return on success or continue to the method body."
<var: #primitiveRoutine declareC: 'void (*primitiveRoutine)(void)'>
| flags jmp jmpSamplePrim retry continuePostSamplePrim jmpSampleNonPrim continuePostSampleNonPrim |
<var: #jmp type: #'AbstractInstruction *'>
<var: #retry type: #'AbstractInstruction *'>
<var: #jmpSamplePrim type: #'AbstractInstruction *'>
<var: #continuePostSamplePrim type: #'AbstractInstruction *'>
<var: #jmpSampleNonPrim type: #'AbstractInstruction *'>
<var: #continuePostSampleNonPrim type: #'AbstractInstruction *'>
"Save processor fp, sp and return pc in the interpreter's frame stack and instruction pointers"
self genExternalizePointersForPrimitiveCall.
"Switch to the C stack."
self genLoadCStackPointersForPrimCall.
flags := coInterpreter primitivePropertyFlags: primitiveIndex.
(flags anyMask: PrimCallDoNotJIT) ifTrue:
[^ShouldNotJIT].
(flags anyMask: PrimCallCollectsProfileSamples) ifTrue:
["Test nextProfileTick for being non-zero and call checkProfileTick if so"
+ objectMemory wordSize = 4
- BytesPerWord = 4
ifTrue:
[self MoveAw: coInterpreter nextProfileTickAddress R: TempReg.
+ self MoveAw: coInterpreter nextProfileTickAddress + objectMemory wordSize R: ClassReg.
- self MoveAw: coInterpreter nextProfileTickAddress + BytesPerWord R: ClassReg.
self OrR: TempReg R: ClassReg]
ifFalse:
[self MoveAw: coInterpreter nextProfileTickAddress R: TempReg.
self CmpCq: 0 R: TempReg].
"If set, jump to record sample call."
jmpSampleNonPrim := self JumpNonZero: 0.
continuePostSampleNonPrim := self Label].
"Old full prim trace is in VMMaker-eem.550 and prior"
self recordPrimTrace ifTrue:
[self genFastPrimTraceUsing: ClassReg and: SendNumArgsReg].
"Clear the primFailCode and set argumentCount"
retry := self MoveCq: 0 R: TempReg.
self MoveR: TempReg Aw: coInterpreter primFailCodeAddress.
methodOrBlockNumArgs ~= 0 ifTrue:
[self MoveCq: methodOrBlockNumArgs R: TempReg].
self MoveR: TempReg Aw: coInterpreter argumentCountAddress.
"If required, set primitiveFunctionPointer and newMethod"
(flags anyMask: PrimCallNeedsPrimitiveFunction) ifTrue:
[self MoveCw: primitiveRoutine asInteger R: TempReg.
self MoveR: TempReg Aw: coInterpreter primitiveFunctionPointerAddress].
(flags anyMask: PrimCallNeedsNewMethod+PrimCallMayCallBack) ifTrue:
["The ceActivateFailingPrimitiveMethod: machinery can't handle framelessness."
(flags anyMask: PrimCallMayCallBack) ifTrue:
[needsFrame := true].
methodLabel addDependent:
(self annotateAbsolutePCRef:
(self MoveCw: methodLabel asInteger R: ClassReg)).
self MoveMw: (self offset: CogMethod of: #methodObject) r: ClassReg R: TempReg.
self MoveR: TempReg Aw: coInterpreter newMethodAddress].
"Invoke the primitive"
self PrefetchAw: coInterpreter primFailCodeAddress.
(flags anyMask: PrimCallMayCallBack)
ifTrue: "Sideways call the C primitive routine so that we return through cePrimReturnEnterCogCode."
["On Spur ceActivateFailingPrimitiveMethod: would like to retry if forwarders
are found. So insist on PrimCallNeedsPrimitiveFunction being set too."
self assert: (flags anyMask: PrimCallNeedsPrimitiveFunction).
backEnd genSubstituteReturnAddress:
((flags anyMask: PrimCallCollectsProfileSamples)
ifTrue: [cePrimReturnEnterCogCodeProfiling]
ifFalse: [cePrimReturnEnterCogCode]).
self JumpRT: primitiveRoutine asInteger.
primInvokeLabel := self Label.
jmp := jmpSamplePrim := continuePostSamplePrim := nil]
ifFalse:
["Call the C primitive routine."
self CallRT: primitiveRoutine asInteger.
primInvokeLabel := self Label.
(flags anyMask: PrimCallCollectsProfileSamples) ifTrue:
[self assert: (flags anyMask: PrimCallNeedsNewMethod).
"Test nextProfileTick for being non-zero and call checkProfileTick if so"
+ objectMemory wordSize = 4
- BytesPerWord = 4
ifTrue:
[self MoveAw: coInterpreter nextProfileTickAddress R: TempReg.
+ self MoveAw: coInterpreter nextProfileTickAddress + objectMemory wordSize R: ClassReg.
- self MoveAw: coInterpreter nextProfileTickAddress + BytesPerWord R: ClassReg.
self OrR: TempReg R: ClassReg]
ifFalse:
[self MoveAw: coInterpreter nextProfileTickAddress R: TempReg.
self CmpCq: 0 R: TempReg].
"If set, jump to record sample call."
jmpSamplePrim := self JumpNonZero: 0.
continuePostSamplePrim := self Label].
objectRepresentation maybeCompileRetry: retry onPrimitiveFail: primitiveIndex.
self maybeCompileAllocFillerCheck.
"Switch back to the Smalltalk stack. Stack better be in either of these two states:
success: stackPointer -> result (was receiver)
arg1
...
argN
return pc
failure: receiver
arg1
...
stackPointer -> argN
return pc
In either case we can push the instructionPointer or load it into the LinkRegister to reestablish the return pc"
self MoveAw: coInterpreter instructionPointerAddress
R: (backEnd hasLinkRegister ifTrue: [LinkReg] ifFalse: [ClassReg]).
backEnd genLoadStackPointers.
"Test primitive failure"
self MoveAw: coInterpreter primFailCodeAddress R: TempReg.
backEnd hasLinkRegister ifFalse: [self PushR: ClassReg]. "Restore return pc on CISCs"
self flag: 'ask concrete code gen if move sets condition codes?'.
self CmpCq: 0 R: TempReg.
jmp := self JumpNonZero: 0.
"Fetch result from stack"
+ self MoveMw: objectMemory wordSize r: SPReg R: ReceiverResultReg.
- self MoveMw: BytesPerWord r: SPReg R: ReceiverResultReg.
self flag: 'currently caller pushes result'.
+ self RetN: objectMemory wordSize]. "return to caller, popping receiver"
- self RetN: BytesPerWord]. "return to caller, popping receiver"
(flags anyMask: PrimCallCollectsProfileSamples) ifTrue:
["The sample is collected by cePrimReturnEnterCogCode for external calls"
jmpSamplePrim notNil ifTrue:
["Call ceCheckProfileTick: to record sample and then continue."
jmpSamplePrim jmpTarget: self Label.
self assert: (flags anyMask: PrimCallNeedsNewMethod).
self CallRT: (self cCode: [#ceCheckProfileTick asUnsignedLong]
inSmalltalk: [self simulatedTrampolineFor: #ceCheckProfileTick]).
"reenter the post-primitive call flow"
self Jump: continuePostSamplePrim].
"Null newMethod and call ceCheckProfileTick: to record sample and then continue.
ceCheckProfileTick will map null/0 to coInterpreter nilObject"
jmpSampleNonPrim jmpTarget: self Label.
self MoveCq: 0 R: TempReg.
self MoveR: TempReg Aw: coInterpreter newMethodAddress.
self CallRT: (self cCode: [#ceCheckProfileTick asUnsignedLong]
inSmalltalk: [self simulatedTrampolineFor: #ceCheckProfileTick]).
"reenter the post-primitive call flow"
self Jump: continuePostSampleNonPrim].
jmp notNil ifTrue:
["Jump to restore of receiver reg and proceed to frame build for failure."
jmp jmpTarget: self Label.
"Restore receiver reg from stack. If on RISCs ret pc is in LinkReg, if on CISCs ret pc is on stack."
+ self MoveMw: objectMemory wordSize * (methodOrBlockNumArgs + (backEnd hasLinkRegister ifTrue: [0] ifFalse: [1]))
- self MoveMw: BytesPerWord * (methodOrBlockNumArgs + (backEnd hasLinkRegister ifTrue: [0] ifFalse: [1]))
r: SPReg
R: ReceiverResultReg].
^0!
Item was changed:
----- Method: SimpleStackBasedCogit>>compileOpenPIC:numArgs: (in category 'in-line cacheing') -----
compileOpenPIC: selector numArgs: numArgs
"Compile the code for an open PIC. Perform a probe of the first-level method
lookup cache followed by a call of ceSendFromInLineCacheMiss: if the probe fails."
| jumpSelectorMiss jumpClassMiss itsAHit jumpBCMethod |
<var: #jumpSelectorMiss type: #'AbstractInstruction *'>
<var: #jumpClassMiss type: #'AbstractInstruction *'>
<var: #itsAHit type: #'AbstractInstruction *'>
<var: #jumpBCMethod type: #'AbstractInstruction *'>
self compilePICProlog: numArgs.
self cppIf: NewspeakVM ifTrue:
[self Nop. "1st nop differentiates dynSuperEntry from no-check entry if using nextMethod"
dynSuperEntry := self Nop].
entry := objectRepresentation genGetClassTagOf: ReceiverResultReg into: ClassReg scratchReg: TempReg.
"Do first of three probes. See CoInterpreter>>lookupInMethodCacheSel:classTag:"
self flag: #lookupInMethodCacheSel:classTag:. "so this method shows up as a sender of lookupInMethodCacheSel:class:"
self MoveR: ClassReg R: SendNumArgsReg.
self annotate: (self XorCw: selector R: ClassReg) objRef: selector.
+ self LogicalShiftLeftCq: objectMemory shiftForWord R: ClassReg.
+ self AndCq: MethodCacheMask << objectMemory shiftForWord R: ClassReg.
+ self MoveMw: coInterpreter methodCacheAddress asUnsignedInteger + (MethodCacheSelector << objectMemory shiftForWord)
- self LogicalShiftLeftCq: ShiftForWord R: ClassReg.
- self AndCq: MethodCacheMask << ShiftForWord R: ClassReg.
- self MoveMw: coInterpreter methodCacheAddress asUnsignedInteger + (MethodCacheSelector << ShiftForWord)
r: ClassReg
R: TempReg.
self annotate: (self CmpCw: selector R: TempReg) objRef: selector.
jumpSelectorMiss := self JumpNonZero: 0.
+ self MoveMw: coInterpreter methodCacheAddress asUnsignedInteger + (MethodCacheClass << objectMemory shiftForWord)
- self MoveMw: coInterpreter methodCacheAddress asUnsignedInteger + (MethodCacheClass << ShiftForWord)
r: ClassReg
R: TempReg.
self CmpR: SendNumArgsReg R: TempReg.
jumpClassMiss := self JumpNonZero: 0.
itsAHit := self Label.
"Fetch the method. The interpret trampoline requires the bytecoded method in SendNumArgsReg"
+ self MoveMw: coInterpreter methodCacheAddress asUnsignedInteger + (MethodCacheMethod << objectMemory shiftForWord)
- self MoveMw: coInterpreter methodCacheAddress asUnsignedInteger + (MethodCacheMethod << ShiftForWord)
r: ClassReg
R: SendNumArgsReg.
"If the method is compiled jump to its unchecked entry-point, otherwise interpret it."
objectRepresentation
genLoadSlot: HeaderIndex sourceReg: SendNumArgsReg destReg: TempReg.
self MoveR: TempReg R: ClassReg.
jumpBCMethod := objectRepresentation genJumpSmallIntegerInScratchReg: TempReg.
jumpBCMethod jmpTarget: interpretLabel.
self AddCq: cmNoCheckEntryOffset R: ClassReg.
self JumpR: ClassReg.
"First probe missed. Do second of three probes. Shift hash right one and retry."
jumpSelectorMiss jmpTarget: (jumpClassMiss jmpTarget: self Label).
self MoveR: SendNumArgsReg R: ClassReg.
self annotate: (self XorCw: selector R: ClassReg) objRef: selector.
+ self LogicalShiftLeftCq: objectMemory shiftForWord - 1 R: ClassReg.
+ self AndCq: MethodCacheMask << objectMemory shiftForWord R: ClassReg.
+ self MoveMw: coInterpreter methodCacheAddress asUnsignedInteger + (MethodCacheSelector << objectMemory shiftForWord)
- self LogicalShiftLeftCq: ShiftForWord - 1 R: ClassReg.
- self AndCq: MethodCacheMask << ShiftForWord R: ClassReg.
- self MoveMw: coInterpreter methodCacheAddress asUnsignedInteger + (MethodCacheSelector << ShiftForWord)
r: ClassReg
R: TempReg.
self annotate: (self CmpCw: selector R: TempReg) objRef: selector.
jumpSelectorMiss := self JumpNonZero: 0.
+ self MoveMw: coInterpreter methodCacheAddress asUnsignedInteger + (MethodCacheClass << objectMemory shiftForWord)
- self MoveMw: coInterpreter methodCacheAddress asUnsignedInteger + (MethodCacheClass << ShiftForWord)
r: ClassReg
R: TempReg.
self CmpR: SendNumArgsReg R: TempReg.
self JumpZero: itsAHit.
"Second probe missed. Do last probe. Shift hash right two and retry."
jumpSelectorMiss jmpTarget: self Label.
self MoveR: SendNumArgsReg R: ClassReg.
self annotate: (self XorCw: selector R: ClassReg) objRef: selector.
+ objectMemory shiftForWord > 2 ifTrue:
+ [self LogicalShiftLeftCq: objectMemory shiftForWord - 1 R: ClassReg].
+ self AndCq: MethodCacheMask << objectMemory shiftForWord R: ClassReg.
+ self MoveMw: coInterpreter methodCacheAddress asUnsignedInteger + (MethodCacheSelector << objectMemory shiftForWord)
- ShiftForWord > 2 ifTrue:
- [self LogicalShiftLeftCq: ShiftForWord - 1 R: ClassReg].
- self AndCq: MethodCacheMask << ShiftForWord R: ClassReg.
- self MoveMw: coInterpreter methodCacheAddress asUnsignedInteger + (MethodCacheSelector << ShiftForWord)
r: ClassReg
R: TempReg.
self annotate: (self CmpCw: selector R: TempReg) objRef: selector.
jumpSelectorMiss := self JumpNonZero: 0.
+ self MoveMw: coInterpreter methodCacheAddress asUnsignedInteger + (MethodCacheClass << objectMemory shiftForWord)
- self MoveMw: coInterpreter methodCacheAddress asUnsignedInteger + (MethodCacheClass << ShiftForWord)
r: ClassReg
R: TempReg.
self CmpR: SendNumArgsReg R: TempReg.
self JumpZero: itsAHit.
"Last probe missed. Call ceSendFromInLineCacheMiss: to do the full lookup."
jumpSelectorMiss jmpTarget: self Label.
backEnd genSaveStackPointers.
backEnd genLoadCStackPointers.
methodLabel addDependent: (self annotateAbsolutePCRef: (self MoveCw: methodLabel asInteger R: SendNumArgsReg)).
self
compileCallFor: #ceSendFromInLineCacheMiss:
numArgs: 1
arg: SendNumArgsReg
arg: nil
arg: nil
arg: nil
resultReg: nil
saveRegs: false
"Note that this call does not return."!
Item was changed:
----- Method: SimpleStackBasedCogit>>frameOffsetOfTemporary: (in category 'bytecode generators') -----
frameOffsetOfTemporary: index
^index < methodOrBlockNumArgs
+ ifTrue: [FoxCallerSavedIP + ((methodOrBlockNumArgs - index) * objectMemory wordSize)]
+ ifFalse: [FoxMFReceiver - objectMemory wordSize + ((methodOrBlockNumArgs - index) * objectMemory wordSize)]!
- ifTrue: [FoxCallerSavedIP + ((methodOrBlockNumArgs - index) * BytesPerWord)]
- ifFalse: [FoxMFReceiver - BytesPerWord + ((methodOrBlockNumArgs - index) * BytesPerWord)]!
Item was changed:
----- Method: SimpleStackBasedCogit>>genBlockReturn (in category 'bytecode generators') -----
genBlockReturn
"Return from block, assuming result already loaded into ReceiverResultReg."
needsFrame ifTrue:
[self MoveR: FPReg R: SPReg.
self PopR: FPReg].
"Tim, I disagree; link reg should only be popped if frameful.
Frameless methods should /not/ push the link reg except around trampolines.
Eliot"
backEnd hasLinkRegister ifTrue:
[self PopR: LinkReg].
+ self RetN: methodOrBlockNumArgs + 1 * objectMemory wordSize.
- self RetN: methodOrBlockNumArgs + 1 * BytesPerWord.
^0!
Item was changed:
----- Method: SimpleStackBasedCogit>>genDoubleArithmetic:preOpCheck: (in category 'primitive generators') -----
genDoubleArithmetic: arithmeticOperator preOpCheck: preOpCheckOrNil
"Stack looks like
receiver (also in ResultReceiverReg)
arg
return address"
<var: #preOpCheckOrNil declareC: 'AbstractInstruction *(*preOpCheckOrNil)(int rcvrReg, int argReg)'>
| jumpFailClass jumpFailAlloc jumpFailCheck jumpImmediate jumpNonInt doOp fail |
<var: #jumpFailClass type: #'AbstractInstruction *'>
<var: #jumpFailAlloc type: #'AbstractInstruction *'>
<var: #jumpNonInt type: #'AbstractInstruction *'>
<var: #jumpImmediate type: #'AbstractInstruction *'>
<var: #jumpFailCheck type: #'AbstractInstruction *'>
<var: #doOp type: #'AbstractInstruction *'>
<var: #fail type: #'AbstractInstruction *'>
+ self MoveMw: objectMemory wordSize r: SPReg R: TempReg.
- self MoveMw: BytesPerWord r: SPReg R: TempReg.
objectRepresentation genGetDoubleValueOf: ReceiverResultReg into: DPFPReg0.
self MoveR: TempReg R: ClassReg.
jumpImmediate := objectRepresentation genJumpImmediateInScratchReg: TempReg.
objectRepresentation genGetCompactClassIndexNonImmOf: ClassReg into: SendNumArgsReg.
objectRepresentation genCmpClassFloatCompactIndexR: SendNumArgsReg.
jumpFailClass := self JumpNonZero: 0.
objectRepresentation genGetDoubleValueOf: ClassReg into: DPFPReg1.
doOp := self Label.
preOpCheckOrNil ifNotNil:
[jumpFailCheck := self perform: preOpCheckOrNil with: DPFPReg0 with: DPFPReg1].
self gen: arithmeticOperator operand: DPFPReg1 operand: DPFPReg0.
jumpFailAlloc := objectRepresentation
genAllocFloatValue: DPFPReg0
into: SendNumArgsReg
scratchReg: ClassReg
scratchReg: TempReg.
self MoveR: SendNumArgsReg R: ReceiverResultReg.
self flag: 'currently caller pushes result'.
+ self RetN: objectMemory wordSize * 2.
- self RetN: BytesPerWord * 2.
jumpImmediate jmpTarget: self Label.
objectRepresentation smallIntegerIsOnlyImmediateType ifFalse:
[jumpNonInt := objectRepresentation genJumpNotSmallIntegerInScratchReg: TempReg].
objectRepresentation genConvertSmallIntegerToIntegerInReg: ClassReg.
self ConvertR: ClassReg Rd: DPFPReg1.
self Jump: doOp.
jumpFailAlloc jmpTarget: self Label.
self compileFallbackToInterpreterPrimitive.
fail := self Label.
jumpFailClass jmpTarget: fail.
preOpCheckOrNil ifNotNil:
[jumpFailCheck jmpTarget: fail].
objectRepresentation smallIntegerIsOnlyImmediateType ifFalse:
[jumpNonInt jmpTarget: fail].
^0!
Item was changed:
----- Method: SimpleStackBasedCogit>>genDoubleComparison:invert: (in category 'primitive generators') -----
genDoubleComparison: jumpOpcodeGenerator invert: invertComparison
"Stack looks like
receiver (also in ResultReceiverReg)
arg
return address"
<var: #jumpOpcodeGenerator declareC: 'AbstractInstruction *(*jumpOpcodeGenerator)(void *)'>
| jumpFail jumpImmediate jumpNonInt jumpCond compare |
<var: #jumpImmediate type: #'AbstractInstruction *'>
<var: #jumpNonInt type: #'AbstractInstruction *'>
<var: #jumpCond type: #'AbstractInstruction *'>
<var: #compare type: #'AbstractInstruction *'>
<var: #jumpFail type: #'AbstractInstruction *'>
+ self MoveMw: objectMemory wordSize r: SPReg R: TempReg.
- self MoveMw: BytesPerWord r: SPReg R: TempReg.
objectRepresentation genGetDoubleValueOf: ReceiverResultReg into: DPFPReg0.
self MoveR: TempReg R: ClassReg.
jumpImmediate := objectRepresentation genJumpImmediateInScratchReg: TempReg.
objectRepresentation genGetCompactClassIndexNonImmOf: ClassReg into: SendNumArgsReg.
objectRepresentation genCmpClassFloatCompactIndexR: SendNumArgsReg.
jumpFail := self JumpNonZero: 0.
objectRepresentation genGetDoubleValueOf: ClassReg into: DPFPReg1.
invertComparison "May need to invert for NaNs"
ifTrue: [compare := self CmpRd: DPFPReg0 Rd: DPFPReg1]
ifFalse: [compare := self CmpRd: DPFPReg1 Rd: DPFPReg0].
jumpCond := self perform: jumpOpcodeGenerator with: 0. "FP jumps are a little weird"
self annotate: (self MoveCw: objectMemory falseObject R: ReceiverResultReg)
objRef: objectMemory falseObject.
self flag: 'currently caller pushes result'.
+ self RetN: objectMemory wordSize * 2.
- self RetN: BytesPerWord * 2.
jumpCond jmpTarget: (self annotate: (self MoveCw: objectMemory trueObject R: ReceiverResultReg)
objRef: objectMemory trueObject).
+ self RetN: objectMemory wordSize * 2.
- self RetN: BytesPerWord * 2.
jumpImmediate jmpTarget: self Label.
objectRepresentation smallIntegerIsOnlyImmediateType ifFalse:
[jumpNonInt := objectRepresentation genJumpNotSmallIntegerInScratchReg: TempReg].
objectRepresentation genConvertSmallIntegerToIntegerInReg: ClassReg.
self ConvertR: ClassReg Rd: DPFPReg1.
self Jump: compare.
jumpFail jmpTarget: self Label.
objectRepresentation smallIntegerIsOnlyImmediateType ifFalse:
[jumpNonInt jmpTarget: jumpFail getJmpTarget].
^0!
Item was changed:
----- Method: SimpleStackBasedCogit>>genGetImplicitReceiverFor:forPush: (in category 'bytecode generators') -----
genGetImplicitReceiverFor: selector forPush: forPushSendBar
"Cached implicit receiver implementation. If objectRepresentation doesn't support
pinning then caller looks like
mov selector, ClassReg
call ceImplicitReceiverTrampoline
br continue
Lclass .word
Lmixin: .word
continue:
If objectRepresentation supports pinning then caller looks like
mov Lclass, Arg1Reg
mov selector, SendNumArgsReg
call ceImplicitReceiver
and Lclass: .word; Lmixin: .word is somewhere on the heap.
If class matches class of receiver then mixin contains either 0 or the implicit receiver.
If 0, answer the actual receiver. This is done in the trampoline.
See generateNewspeakRuntime."
| skip |
<var: #skip type: #'AbstractInstruction *'>
"N.B. For PC mapping either this is used for SendAbsentImplicit or for PushAbsentReceiver
but not both. So any Newspeak instruction set has to choose either SendAbsentImplicit
or PushImplicitReceiver. See isPCMappedAnnotation:alternateInstructionSet:"
self assert: forPushSendBar = (self isPCMappedAnnotation: IsNSSendCall
alternateInstructionSet: bytecodeSetOffset > 0).
self assert: (self noAssertMethodClassAssociationOf: methodObj) ~= objectMemory nilObject.
self assert: needsFrame.
(objectMemory isYoung: selector) ifTrue:
[hasYoungReferent := true].
objectRepresentation canPinObjects ifTrue:
+ [self MoveCw: theIRCs + (2 * objectMemory bytesPerOop * indexOfIRC) R: Arg1Reg.
- [self MoveCw: theIRCs + (2 * BytesPerOop * indexOfIRC) R: Arg1Reg.
self MoveCw: selector R: SendNumArgsReg.
self CallNewspeakSend: ceImplicitReceiverTrampoline.
indexOfIRC := indexOfIRC + 1.
^0].
self MoveCw: selector R: SendNumArgsReg.
self CallNewspeakSend: ceImplicitReceiverTrampoline.
skip := self Jump: 0.
self Fill32: 0.
self Fill32: 0.
skip jmpTarget: self Label.
^0!
Item was changed:
----- Method: SimpleStackBasedCogit>>genPopStackBytecode (in category 'bytecode generators') -----
genPopStackBytecode
+ self AddCq: objectMemory wordSize R: SPReg.
- self AddCq: BytesPerWord R: SPReg.
^0!
Item was changed:
----- Method: SimpleStackBasedCogit>>genPrimReturnEnterCogCodeEnilopmart: (in category 'initialization') -----
genPrimReturnEnterCogCodeEnilopmart: profiling
"Generate the substitute return code for an external or FFI primitive call.
On success simply return, extracting numArgs from newMethod.
On primitive failure call ceActivateFailingPrimitiveMethod: newMethod."
| jmpSample continuePostSample jmpFail |
<var: #jmpSample type: #'AbstractInstruction *'>
<var: #continuePostSample type: #'AbstractInstruction *'>
<var: #jmpFail type: #'AbstractInstruction *'>
opcodeIndex := 0.
profiling ifTrue:
["Test nextProfileTick for being non-zero and call checkProfileTick: if so.
N.B. nextProfileTick is 64-bits so 32-bit systems need to test both halves."
+ objectMemory wordSize = 4
- BytesPerWord = 4
ifTrue:
[self MoveAw: coInterpreter nextProfileTickAddress R: TempReg.
+ self MoveAw: coInterpreter nextProfileTickAddress + objectMemory wordSize R: ClassReg.
- self MoveAw: coInterpreter nextProfileTickAddress + BytesPerWord R: ClassReg.
self OrR: TempReg R: ClassReg]
ifFalse:
[self MoveAw: coInterpreter nextProfileTickAddress R: TempReg.
self CmpCq: 0 R: TempReg].
"If set, jump to record sample call."
jmpSample := self JumpNonZero: 0.
continuePostSample := self Label].
self maybeCompileAllocFillerCheck.
"Test primitive failure"
self MoveAw: coInterpreter primFailCodeAddress R: TempReg.
self flag: 'ask concrete code gen if move sets condition codes?'.
self CmpCq: 0 R: TempReg.
jmpFail := self JumpNonZero: 0.
"Switch back to the Smalltalk stack. Stack better be in either of these two states:
success: stackPointer -> result (was receiver)
arg1
...
argN
return pc
failure: receiver
arg1
...
stackPointer -> argN
return pc
We push the instructionPointer to reestablish the return pc in the success case,
but leave it to ceActivateFailingPrimitiveMethod: to do so in the failure case."
backEnd hasLinkRegister
ifTrue:
[backEnd genLoadStackPointers. "Switch back to Smalltalk stack."
self MoveMw: 0 r: SPReg R: ReceiverResultReg. "Fetch result from stack"
self MoveAw: coInterpreter instructionPointerAddress R: LinkReg. "Get and restore ret pc"
+ self RetN: objectMemory wordSize] "Return, popping result from stack"
- self RetN: BytesPerWord] "Return, popping result from stack"
ifFalse:
[self MoveAw: coInterpreter instructionPointerAddress R: ClassReg. "Get return pc"
backEnd genLoadStackPointers. "Switch back to Smalltalk stack."
self MoveMw: 0 r: SPReg R: ReceiverResultReg. "Fetch result from stack"
self MoveR: ClassReg Mw: 0 r: SPReg. "Restore return pc"
self RetN: 0]. "Return, popping result from stack"
"Primitive failed. Invoke C code to build the frame and continue."
jmpFail jmpTarget: (self MoveAw: coInterpreter newMethodAddress R: SendNumArgsReg).
"Reload sp with CStackPointer; easier than popping args of checkProfileTick."
self MoveAw: self cStackPointerAddress R: SPReg.
self
compileCallFor: #ceActivateFailingPrimitiveMethod:
numArgs: 1
arg: SendNumArgsReg
arg: nil
arg: nil
arg: nil
resultReg: nil
saveRegs: false.
"On Spur ceActivateFailingPrimitiveMethod: may retry the primitive and return if successful.
So continue by returning to the caller.
Switch back to the Smalltalk stack. Stack should be in this state:
success: stackPointer -> result (was receiver)
arg1
...
argN
return pc
We can push the instructionPointer or load it into the LinkRegister to reestablish the return pc"
self MoveAw: coInterpreter instructionPointerAddress
R: (backEnd hasLinkRegister ifTrue: [LinkReg] ifFalse: [ClassReg]).
backEnd genLoadStackPointers.
backEnd hasLinkRegister
ifTrue:
[self MoveMw: 0 r: SPReg R: ReceiverResultReg] "Fetch result from stack"
ifFalse:
+ [self MoveMw: objectMemory wordSize r: SPReg R: ReceiverResultReg. "Fetch result from stack"
- [self MoveMw: BytesPerWord r: SPReg R: ReceiverResultReg. "Fetch result from stack"
self PushR: ClassReg]. "Restore return pc on CISCs"
self flag: 'currently caller pushes result'.
+ self RetN: objectMemory wordSize. "return to caller, popping receiver"
- self RetN: BytesPerWord. "return to caller, popping receiver"
profiling ifTrue:
["Call ceCheckProfileTick: to record sample and then continue. newMethod
should be up-to-date. Need to save and restore the link reg around this call."
jmpSample jmpTarget: self Label.
backEnd hasLinkRegister ifTrue: [self PushR: LinkReg].
self CallRT: (self cCode: '(unsigned long)ceCheckProfileTick'
inSmalltalk: [self simulatedTrampolineFor: #ceCheckProfileTick]).
backEnd hasLinkRegister ifTrue: [self PopR: LinkReg].
self Jump: continuePostSample]!
Item was changed:
----- Method: SimpleStackBasedCogit>>genPrimitiveAdd (in category 'primitive generators') -----
genPrimitiveAdd
"Stack looks like
receiver (also in ResultReceiverReg)
arg
return address"
| jumpNotSI jumpOvfl |
<var: #jumpNotSI type: #'AbstractInstruction *'>
<var: #jumpOvfl type: #'AbstractInstruction *'>
+ self MoveMw: objectMemory wordSize r: SPReg R: TempReg.
- self MoveMw: BytesPerWord r: SPReg R: TempReg.
self MoveR: TempReg R: ClassReg.
jumpNotSI := objectRepresentation genJumpNotSmallIntegerInScratchReg: TempReg.
objectRepresentation genRemoveSmallIntegerTagsInScratchReg: ClassReg.
self MoveR: ReceiverResultReg R: TempReg.
self AddR: ClassReg R: TempReg.
jumpOvfl := self JumpOverflow: 0.
self MoveR: TempReg R: ReceiverResultReg.
self flag: 'currently caller pushes result'.
+ self RetN: objectMemory wordSize * 2.
- self RetN: BytesPerWord * 2.
jumpOvfl jmpTarget: (jumpNotSI jmpTarget: self Label).
^0!
Item was changed:
----- Method: SimpleStackBasedCogit>>genPrimitiveAsCharacter (in category 'primitive generators') -----
genPrimitiveAsCharacter
| na r |
na := coInterpreter argumentCountOf: methodObj.
na <= 1 ifTrue:
[na = 1 ifTrue:
+ [self MoveMw: objectMemory wordSize r: SPReg R: Arg0Reg].
- [self MoveMw: BytesPerWord r: SPReg R: Arg0Reg].
(r := objectRepresentation
genInnerPrimitiveAsCharacter: 0
inReg: (na = 0 ifTrue: [ReceiverResultReg] ifFalse: [Arg0Reg])) < 0 ifTrue:
[^r]].
^self compileFallbackToInterpreterPrimitive!
Item was changed:
----- Method: SimpleStackBasedCogit>>genPrimitiveAsFloat (in category 'primitive generators') -----
genPrimitiveAsFloat
"Stack looks like
receiver (also in ResultReceiverReg)
return address"
| jumpFailAlloc |
<var: #jumpFailAlloc type: #'AbstractInstruction *'>
self MoveR: ReceiverResultReg R: ClassReg.
objectRepresentation genConvertSmallIntegerToIntegerInReg: ClassReg.
self ConvertR: ClassReg Rd: DPFPReg0.
jumpFailAlloc := objectRepresentation
genAllocFloatValue: DPFPReg0
into: SendNumArgsReg
scratchReg: ClassReg
scratchReg: TempReg.
self MoveR: SendNumArgsReg R: ReceiverResultReg.
self flag: 'currently caller pushes result'.
+ self RetN: objectMemory wordSize.
- self RetN: BytesPerWord.
jumpFailAlloc jmpTarget: self Label.
^self compileFallbackToInterpreterPrimitive!
Item was changed:
----- Method: SimpleStackBasedCogit>>genPrimitiveAt (in category 'primitive generators') -----
genPrimitiveAt
| r |
+ self MoveMw: objectMemory wordSize r: SPReg R: Arg0Reg.
+ (r := objectRepresentation genInnerPrimitiveAt: objectMemory wordSize * 2) < 0 ifTrue:
- self MoveMw: BytesPerWord r: SPReg R: Arg0Reg.
- (r := objectRepresentation genInnerPrimitiveAt: BytesPerWord * 2) < 0 ifTrue:
[^r].
^self compileFallbackToInterpreterPrimitive!
Item was changed:
----- Method: SimpleStackBasedCogit>>genPrimitiveAtPut (in category 'primitive generators') -----
genPrimitiveAtPut
| r |
+ self MoveMw: objectMemory wordSize * 2 r: SPReg R: Arg0Reg.
+ self MoveMw: objectMemory wordSize r: SPReg R: Arg1Reg.
+ ((r := objectRepresentation genInnerPrimitiveAtPut: objectMemory wordSize * 3) < 0
- self MoveMw: BytesPerWord * 2 r: SPReg R: Arg0Reg.
- self MoveMw: BytesPerWord r: SPReg R: Arg1Reg.
- ((r := objectRepresentation genInnerPrimitiveAtPut: BytesPerWord * 3) < 0
and: [r ~= UnimplementedPrimitive]) ifTrue:
[^r].
^self compileFallbackToInterpreterPrimitive!
Item was changed:
----- Method: SimpleStackBasedCogit>>genPrimitiveBitAnd (in category 'primitive generators') -----
genPrimitiveBitAnd
| jumpNotSI |
<var: #jumpNotSI type: #'AbstractInstruction *'>
+ self MoveMw: objectMemory wordSize r: SPReg R: TempReg.
- self MoveMw: BytesPerWord r: SPReg R: TempReg.
self MoveR: TempReg R: ClassReg.
jumpNotSI := objectRepresentation genJumpNotSmallIntegerInScratchReg: TempReg.
"Whether the SmallInteger tags are zero or non-zero, anding them together will preserve them."
self AndR: ClassReg R: ReceiverResultReg.
self flag: 'currently caller pushes result'.
+ self RetN: objectMemory wordSize * 2.
- self RetN: BytesPerWord * 2.
jumpNotSI jmpTarget: self Label.
^0!
Item was changed:
----- Method: SimpleStackBasedCogit>>genPrimitiveBitOr (in category 'primitive generators') -----
genPrimitiveBitOr
| jumpNotSI |
<var: #jumpNotSI type: #'AbstractInstruction *'>
+ self MoveMw: objectMemory wordSize r: SPReg R: TempReg.
- self MoveMw: BytesPerWord r: SPReg R: TempReg.
self MoveR: TempReg R: ClassReg.
jumpNotSI := objectRepresentation genJumpNotSmallIntegerInScratchReg: TempReg.
"Whether the SmallInteger tags are zero or non-zero, oring them together will preserve them."
self OrR: ClassReg R: ReceiverResultReg.
self flag: 'currently caller pushes result'.
+ self RetN: objectMemory wordSize * 2.
- self RetN: BytesPerWord * 2.
jumpNotSI jmpTarget: self Label.
^0!
Item was changed:
----- Method: SimpleStackBasedCogit>>genPrimitiveBitShift (in category 'primitive generators') -----
genPrimitiveBitShift
"Stack looks like
receiver (also in ResultReceiverReg)
arg
return address
rTemp := ArgOffset(SP)
rClass := tTemp
rTemp := rTemp & 1
jz nonInt
rClass >>= 1
cmp 0,rClass
jge neg
cmp 31,rClass // numSmallIntegerBits, jge for sign
jge tooBig
rTemp := rReceiver
rTemp <<= rClass
rTemp >>= rClass (arithmetic)
cmp rTemp,rReceiver
jnz ovfl
rReceiver := rReceiver - 1
rReceiver := rReceiver <<= rClass
rReceiver := rReceiver + 1
ret
neg:
rClass := 0 - rClass
cmp 31,rClass
jge inRange
rClass := 31
inRange
rReceiver := rReceiver >>= rClass.
rReceiver := rReceiver | 1.
ret
ovfl
tooBig
nonInt:
fail"
| jumpNotSI jumpOvfl jumpNegative jumpTooBig jumpInRange |
<var: #jumpNotSI type: #'AbstractInstruction *'>
<var: #jumpOvfl type: #'AbstractInstruction *'>
<var: #jumpNegative type: #'AbstractInstruction *'>
<var: #jumpTooBig type: #'AbstractInstruction *'>
<var: #jumpInRange type: #'AbstractInstruction *'>
+ self MoveMw: objectMemory wordSize r: SPReg R: TempReg.
- self MoveMw: BytesPerWord r: SPReg R: TempReg.
self MoveR: TempReg R: ClassReg.
jumpNotSI := objectRepresentation genJumpNotSmallIntegerInScratchReg: TempReg.
objectRepresentation genConvertSmallIntegerToIntegerInReg: ClassReg.
(self lastOpcode setsConditionCodesFor: JumpNegative) ifFalse:
[self CmpCq: 0 R: ClassReg]. "N.B. FLAGS := ClassReg - 0"
jumpNegative := self JumpNegative: 0.
self CmpCq: objectRepresentation numSmallIntegerBits R: ClassReg. "N.B. FLAGS := ClassReg - 31"
jumpTooBig := self JumpGreaterOrEqual: 0.
self MoveR: ReceiverResultReg R: TempReg.
self LogicalShiftLeftR: ClassReg R: TempReg.
self ArithmeticShiftRightR: ClassReg R: TempReg.
self CmpR: TempReg R: ReceiverResultReg. "N.B. FLAGS := RRReg - TempReg"
jumpOvfl := self JumpNonZero: 0.
objectRepresentation genRemoveSmallIntegerTagsInScratchReg: ReceiverResultReg.
self LogicalShiftLeftR: ClassReg R: ReceiverResultReg.
objectRepresentation genAddSmallIntegerTagsTo: ReceiverResultReg.
+ self RetN: objectMemory wordSize * 2.
- self RetN: BytesPerWord * 2.
jumpNegative jmpTarget: (self NegateR: ClassReg).
self CmpCq: objectRepresentation numSmallIntegerBits R: ClassReg. "N.B. FLAGS := ClassReg - 31"
jumpInRange := self JumpLessOrEqual: 0.
self MoveCq: objectRepresentation numSmallIntegerBits R: ClassReg.
jumpInRange jmpTarget: (self ArithmeticShiftRightR: ClassReg R: ReceiverResultReg).
objectRepresentation genSetSmallIntegerTagsIn: ReceiverResultReg.
+ self RetN: objectMemory wordSize * 2.
- self RetN: BytesPerWord * 2.
jumpNotSI jmpTarget: (jumpTooBig jmpTarget: (jumpOvfl jmpTarget: self Label)).
^0!
Item was changed:
----- Method: SimpleStackBasedCogit>>genPrimitiveBitXor (in category 'primitive generators') -----
genPrimitiveBitXor
| jumpNotSI |
<var: #jumpNotSI type: #'AbstractInstruction *'>
+ self MoveMw: objectMemory wordSize r: SPReg R: TempReg.
- self MoveMw: BytesPerWord r: SPReg R: TempReg.
self MoveR: TempReg R: ClassReg.
jumpNotSI := objectRepresentation genJumpNotSmallIntegerInScratchReg: TempReg.
"Clear one or the other tag so that xoring will preserve them."
objectRepresentation genRemoveSmallIntegerTagsInScratchReg: ClassReg.
self XorR: ClassReg R: ReceiverResultReg.
self flag: 'currently caller pushes result'.
+ self RetN: objectMemory wordSize * 2.
- self RetN: BytesPerWord * 2.
jumpNotSI jmpTarget: self Label.
^0!
Item was changed:
----- Method: SimpleStackBasedCogit>>genPrimitiveCharacterValue (in category 'primitive generators') -----
genPrimitiveCharacterValue
| r |
+ (r := objectRepresentation genInnerPrimitiveCharacterValue: objectMemory wordSize) < 0 ifTrue:
- (r := objectRepresentation genInnerPrimitiveCharacterValue: BytesPerWord) < 0 ifTrue:
[^r].
^self compileFallbackToInterpreterPrimitive!
Item was changed:
----- Method: SimpleStackBasedCogit>>genPrimitiveClass (in category 'primitive generators') -----
genPrimitiveClass
"Stack looks like
receiver (also in ReceiverResultReg)
return address"
(objectRepresentation
genGetClassObjectOf: ReceiverResultReg
into: ReceiverResultReg
scratchReg: TempReg
instRegIsReceiver: methodOrBlockNumArgs = 0) = BadRegisterSet ifTrue:
[objectRepresentation
genGetClassObjectOf: ReceiverResultReg
into: ClassReg
scratchReg: TempReg
instRegIsReceiver: methodOrBlockNumArgs = 0.
self MoveR: ClassReg R: ReceiverResultReg].
self flag: 'currently caller pushes result'.
+ self RetN: objectMemory wordSize.
- self RetN: BytesPerWord.
^0!
Item was changed:
----- Method: SimpleStackBasedCogit>>genPrimitiveDiv (in category 'primitive generators') -----
genPrimitiveDiv
| jumpNotSI jumpZero jumpExact jumpSameSign convert |
<var: #convert type: #'AbstractInstruction *'>
<var: #jumpZero type: #'AbstractInstruction *'>
<var: #jumpNotSI type: #'AbstractInstruction *'>
<var: #jumpExact type: #'AbstractInstruction *'>
<var: #jumpSameSign type: #'AbstractInstruction *'>
+ self MoveMw: objectMemory wordSize r: SPReg R: TempReg.
- self MoveMw: BytesPerWord r: SPReg R: TempReg.
self MoveR: TempReg R: ClassReg.
self MoveR: TempReg R: Arg1Reg.
jumpNotSI := objectRepresentation genJumpNotSmallIntegerInScratchReg: TempReg.
"We must shift away the tags, not just subtract them, so that the
overflow case doesn't actually overflow the machine instruction."
objectRepresentation genShiftAwaySmallIntegerTagsInScratchReg: ClassReg.
(self lastOpcode setsConditionCodesFor: JumpZero) ifFalse:
[self CmpCq: 0 R: ClassReg].
jumpZero := self JumpZero: 0.
self MoveR: ReceiverResultReg R: TempReg.
objectRepresentation genShiftAwaySmallIntegerTagsInScratchReg: TempReg.
self DivR: ClassReg R: TempReg Quo: TempReg Rem: ClassReg.
"If remainder is zero we must check for overflow."
self CmpCq: 0 R: ClassReg.
jumpExact := self JumpZero: 0.
"If arg and remainder signs are different we must round down."
self XorR: ClassReg R: Arg1Reg.
(self lastOpcode setsConditionCodesFor: JumpZero) ifFalse:
[self CmpCq: 0 R: Arg1Reg].
jumpSameSign := self JumpGreaterOrEqual: 0.
self SubCq: 1 R: TempReg.
jumpSameSign jmpTarget: (convert := self Label).
objectRepresentation genConvertIntegerToSmallIntegerInReg: TempReg.
self MoveR: TempReg R: ReceiverResultReg.
self flag: 'currently caller pushes result'.
+ self RetN: objectMemory wordSize * 2.
- self RetN: BytesPerWord * 2.
"test for overflow; the only case is SmallInteger minVal // -1"
jumpExact jmpTarget:
(self CmpCq: (1 << (objectRepresentation numSmallIntegerBits - 1)) R: TempReg).
self JumpLess: convert.
jumpZero jmpTarget: (jumpNotSI jmpTarget: self Label).
^0!
Item was changed:
----- Method: SimpleStackBasedCogit>>genPrimitiveDivide (in category 'primitive generators') -----
genPrimitiveDivide
| jumpNotSI jumpZero jumpInexact jumpOverflow |
<var: #jumpNotSI type: #'AbstractInstruction *'>
<var: #jumpZero type: #'AbstractInstruction *'>
<var: #jumpInexact type: #'AbstractInstruction *'>
<var: #jumpOverflow type: #'AbstractInstruction *'>
+ self MoveMw: objectMemory wordSize r: SPReg R: TempReg.
- self MoveMw: BytesPerWord r: SPReg R: TempReg.
self MoveR: TempReg R: ClassReg.
jumpNotSI := objectRepresentation genJumpNotSmallIntegerInScratchReg: TempReg.
"We must shift away the tags, not just subtract them, so that the
overflow case doesn't actually overflow the machine instruction."
objectRepresentation genShiftAwaySmallIntegerTagsInScratchReg: ClassReg.
jumpZero := self JumpZero: 0.
self MoveR: ReceiverResultReg R: TempReg.
objectRepresentation genShiftAwaySmallIntegerTagsInScratchReg: TempReg.
self DivR: ClassReg R: TempReg Quo: TempReg Rem: ClassReg.
"If remainder is non-zero fail."
self CmpCq: 0 R: ClassReg.
jumpInexact := self JumpNonZero: 0.
"test for overflow; the only case is SmallInteger minVal / -1"
self CmpCq: (1 << (objectRepresentation numSmallIntegerBits - 1)) R: TempReg.
jumpOverflow := self JumpGreaterOrEqual: 0.
objectRepresentation genConvertIntegerToSmallIntegerInReg: TempReg.
self MoveR: TempReg R: ReceiverResultReg.
self flag: 'currently caller pushes result'.
+ self RetN: objectMemory wordSize * 2.
- self RetN: BytesPerWord * 2.
jumpOverflow jmpTarget: (jumpInexact jmpTarget: (jumpZero jmpTarget: (jumpNotSI jmpTarget: self Label))).
^0!
Item was changed:
----- Method: SimpleStackBasedCogit>>genPrimitiveFloatSquareRoot (in category 'primitive generators') -----
genPrimitiveFloatSquareRoot
"Stack looks like
receiver (also in ResultReceiverReg)
return address"
| jumpFailAlloc |
<var: #jumpFailAlloc type: #'AbstractInstruction *'>
objectRepresentation genGetDoubleValueOf: ReceiverResultReg into: DPFPReg0.
self SqrtRd: DPFPReg0.
jumpFailAlloc := objectRepresentation
genAllocFloatValue: DPFPReg0
into: SendNumArgsReg
scratchReg: ClassReg
scratchReg: TempReg.
self MoveR: SendNumArgsReg R: ReceiverResultReg.
self flag: 'currently caller pushes result'.
+ self RetN: objectMemory wordSize.
- self RetN: BytesPerWord.
jumpFailAlloc jmpTarget: self Label.
^self compileFallbackToInterpreterPrimitive!
Item was changed:
----- Method: SimpleStackBasedCogit>>genPrimitiveIdentical (in category 'primitive generators') -----
genPrimitiveIdentical
"Stack looks like
receiver (also in ResultReceiverReg)
arg
return address"
+ self MoveMw: objectMemory wordSize r: SPReg R: TempReg.
- self MoveMw: BytesPerWord r: SPReg R: TempReg.
^objectRepresentation
+ genInnerPrimitiveIdentical: objectMemory wordSize * 2
- genInnerPrimitiveIdentical: BytesPerWord * 2
orNotIf: false!
Item was changed:
----- Method: SimpleStackBasedCogit>>genPrimitiveIdentityHash (in category 'primitive generators') -----
genPrimitiveIdentityHash
| r |
+ (r := objectRepresentation genInnerPrimitiveIdentityHash: objectMemory wordSize) < 0 ifTrue:
- (r := objectRepresentation genInnerPrimitiveIdentityHash: BytesPerWord) < 0 ifTrue:
[^r].
^self compileFallbackToInterpreterPrimitive!
Item was changed:
----- Method: SimpleStackBasedCogit>>genPrimitiveMod (in category 'primitive generators') -----
genPrimitiveMod
| jumpNotSI jumpZero jumpExact jumpSameSign |
<var: #jumpNotSI type: #'AbstractInstruction *'>
<var: #jumpZero type: #'AbstractInstruction *'>
<var: #jumpExact type: #'AbstractInstruction *'>
<var: #jumpSameSign type: #'AbstractInstruction *'>
+ self MoveMw: objectMemory wordSize r: SPReg R: TempReg.
- self MoveMw: BytesPerWord r: SPReg R: TempReg.
self MoveR: TempReg R: ClassReg.
jumpNotSI := objectRepresentation genJumpNotSmallIntegerInScratchReg: TempReg.
objectRepresentation genRemoveSmallIntegerTagsInScratchReg: ClassReg.
jumpZero := self JumpZero: 0.
self MoveR: ClassReg R: Arg1Reg.
self MoveR: ReceiverResultReg R: TempReg.
objectRepresentation genRemoveSmallIntegerTagsInScratchReg: TempReg.
self DivR: ClassReg R: TempReg Quo: TempReg Rem: ClassReg.
"If remainder is zero we're done."
self CmpCq: 0 R: ClassReg.
jumpExact := self JumpZero: 0.
"If arg and remainder signs are different we must reflect around zero."
self XorR: ClassReg R: Arg1Reg.
(self lastOpcode setsConditionCodesFor: JumpZero) ifFalse:
[self CmpCq: 0 R: Arg1Reg].
jumpSameSign := self JumpGreaterOrEqual: 0.
self XorR: ClassReg R: Arg1Reg.
self AddR: Arg1Reg R: ClassReg.
jumpSameSign jmpTarget: (jumpExact jmpTarget: self Label).
objectRepresentation genSetSmallIntegerTagsIn: ClassReg.
self MoveR: ClassReg R: ReceiverResultReg.
self flag: 'currently caller pushes result'.
+ self RetN: objectMemory wordSize * 2.
- self RetN: BytesPerWord * 2.
jumpZero jmpTarget: (jumpNotSI jmpTarget: self Label).
^0!
Item was changed:
----- Method: SimpleStackBasedCogit>>genPrimitiveMultiply (in category 'primitive generators') -----
genPrimitiveMultiply
| jumpNotSI jumpOvfl |
<var: #jumpNotSI type: #'AbstractInstruction *'>
<var: #jumpOvfl type: #'AbstractInstruction *'>
+ self MoveMw: objectMemory wordSize r: SPReg R: TempReg.
- self MoveMw: BytesPerWord r: SPReg R: TempReg.
self MoveR: TempReg R: ClassReg.
jumpNotSI := objectRepresentation genJumpNotSmallIntegerInScratchReg: TempReg.
objectRepresentation genShiftAwaySmallIntegerTagsInScratchReg: ClassReg.
self MoveR: ReceiverResultReg R: TempReg.
objectRepresentation genRemoveSmallIntegerTagsInScratchReg: TempReg.
self MulR: TempReg R: ClassReg.
jumpOvfl := self JumpOverflow: 0.
objectRepresentation genSetSmallIntegerTagsIn: ClassReg.
self MoveR: ClassReg R: ReceiverResultReg.
self flag: 'currently caller pushes result'.
+ self RetN: objectMemory wordSize * 2.
- self RetN: BytesPerWord * 2.
jumpOvfl jmpTarget: (jumpNotSI jmpTarget: self Label).
^0!
Item was changed:
----- Method: SimpleStackBasedCogit>>genPrimitiveNew (in category 'primitive generators') -----
genPrimitiveNew
| r |
+ ((r := objectRepresentation genInnerPrimitiveNew: objectMemory wordSize) < 0
- ((r := objectRepresentation genInnerPrimitiveNew: BytesPerWord) < 0
and: [r ~= UnimplementedPrimitive]) ifTrue:
[^r].
"Call the interpreter primitive either when the machine-code primitive
fails, or if the machine-code primitive is unimplemented."
^self compileFallbackToInterpreterPrimitive!
Item was changed:
----- Method: SimpleStackBasedCogit>>genPrimitiveNewMethod (in category 'primitive generators') -----
genPrimitiveNewMethod
| r |
+ ((r := objectRepresentation genInnerPrimitiveNewMethod: 2 * objectMemory wordSize) < 0
- ((r := objectRepresentation genInnerPrimitiveNewMethod: 2 * BytesPerWord) < 0
and: [r ~= UnimplementedPrimitive]) ifTrue:
[^r].
"Call the interpreter primitive either when the machine-code primitive
fails, or if the machine-code primitive is unimplemented."
^self compileFallbackToInterpreterPrimitive!
Item was changed:
----- Method: SimpleStackBasedCogit>>genPrimitiveNewWithArg (in category 'primitive generators') -----
genPrimitiveNewWithArg
| r |
+ ((r := objectRepresentation genInnerPrimitiveNewWithArg: objectMemory wordSize) < 0
- ((r := objectRepresentation genInnerPrimitiveNewWithArg: BytesPerWord) < 0
and: [r ~= UnimplementedPrimitive]) ifTrue:
[^r].
"Call the interpreter primitive either when the machine-code primitive
fails, or if the machine-code primitive is unimplemented."
^self compileFallbackToInterpreterPrimitive!
Item was changed:
----- Method: SimpleStackBasedCogit>>genPrimitiveNotIdentical (in category 'primitive generators') -----
genPrimitiveNotIdentical
"Stack looks like
receiver (also in ResultReceiverReg)
arg
return address"
+ self MoveMw: objectMemory wordSize r: SPReg R: TempReg.
- self MoveMw: BytesPerWord r: SPReg R: TempReg.
^objectRepresentation
+ genInnerPrimitiveIdentical: objectMemory wordSize * 2
- genInnerPrimitiveIdentical: BytesPerWord * 2
orNotIf: true!
Item was changed:
----- Method: SimpleStackBasedCogit>>genPrimitiveQuo (in category 'primitive generators') -----
genPrimitiveQuo
| jumpNotSI jumpZero jumpOverflow |
<var: #jumpNotSI type: #'AbstractInstruction *'>
<var: #jumpZero type: #'AbstractInstruction *'>
<var: #jumpOverflow type: #'AbstractInstruction *'>
+ self MoveMw: objectMemory wordSize r: SPReg R: TempReg.
- self MoveMw: BytesPerWord r: SPReg R: TempReg.
self MoveR: TempReg R: ClassReg.
jumpNotSI := objectRepresentation genJumpNotSmallIntegerInScratchReg: TempReg.
"We must shift away the tags, not just subtract them, so that the
overflow case doesn't actually overflow the machine instruction."
objectRepresentation genShiftAwaySmallIntegerTagsInScratchReg: ClassReg.
(self lastOpcode setsConditionCodesFor: JumpZero) ifFalse:
[self CmpCq: 0 R: ClassReg].
jumpZero := self JumpZero: 0.
self MoveR: ReceiverResultReg R: TempReg.
objectRepresentation genShiftAwaySmallIntegerTagsInScratchReg: TempReg.
self DivR: ClassReg R: TempReg Quo: TempReg Rem: ClassReg.
"test for overflow; the only case is SmallInteger minVal quo: -1"
self CmpCq: (1 << (objectRepresentation numSmallIntegerBits - 1)) R: TempReg.
jumpOverflow := self JumpGreaterOrEqual: 0.
objectRepresentation genConvertIntegerToSmallIntegerInReg: TempReg.
self MoveR: TempReg R: ReceiverResultReg.
self flag: 'currently caller pushes result'.
+ self RetN: objectMemory wordSize * 2.
- self RetN: BytesPerWord * 2.
jumpOverflow jmpTarget: (jumpZero jmpTarget: (jumpNotSI jmpTarget: self Label)).
^0!
Item was changed:
----- Method: SimpleStackBasedCogit>>genPrimitiveSize (in category 'primitive generators') -----
genPrimitiveSize
| r |
+ (r := objectRepresentation genInnerPrimitiveSize: objectMemory wordSize) < 0 ifTrue:
- (r := objectRepresentation genInnerPrimitiveSize: BytesPerWord) < 0 ifTrue:
[^r].
^self compileFallbackToInterpreterPrimitive!
Item was changed:
----- Method: SimpleStackBasedCogit>>genPrimitiveStringAt (in category 'primitive generators') -----
genPrimitiveStringAt
| r |
+ self MoveMw: objectMemory wordSize r: SPReg R: Arg0Reg.
+ (r := objectRepresentation genInnerPrimitiveStringAt: objectMemory wordSize * 2) < 0 ifTrue:
- self MoveMw: BytesPerWord r: SPReg R: Arg0Reg.
- (r := objectRepresentation genInnerPrimitiveStringAt: BytesPerWord * 2) < 0 ifTrue:
[^r].
^self compileFallbackToInterpreterPrimitive!
Item was changed:
----- Method: SimpleStackBasedCogit>>genPrimitiveStringAtPut (in category 'primitive generators') -----
genPrimitiveStringAtPut
| r |
+ self MoveMw: objectMemory wordSize * 2 r: SPReg R: Arg0Reg.
+ self MoveMw: objectMemory wordSize r: SPReg R: Arg1Reg.
+ ((r := objectRepresentation genInnerPrimitiveStringAtPut: objectMemory wordSize * 3) < 0
- self MoveMw: BytesPerWord * 2 r: SPReg R: Arg0Reg.
- self MoveMw: BytesPerWord r: SPReg R: Arg1Reg.
- ((r := objectRepresentation genInnerPrimitiveStringAtPut: BytesPerWord * 3) < 0
and: [r ~= UnimplementedPrimitive]) ifTrue:
[^r].
^self compileFallbackToInterpreterPrimitive!
Item was changed:
----- Method: SimpleStackBasedCogit>>genPrimitiveSubtract (in category 'primitive generators') -----
genPrimitiveSubtract
"Stack looks like
receiver (also in ResultReceiverReg)
arg
return address"
| jumpNotSI jumpOvfl |
<var: #jumpNotSI type: #'AbstractInstruction *'>
<var: #jumpOvfl type: #'AbstractInstruction *'>
+ self MoveMw: objectMemory wordSize r: SPReg R: TempReg.
- self MoveMw: BytesPerWord r: SPReg R: TempReg.
self MoveR: TempReg R: ClassReg.
jumpNotSI := objectRepresentation genJumpNotSmallIntegerInScratchReg: TempReg.
self MoveR: ReceiverResultReg R: TempReg.
self SubR: ClassReg R: TempReg.
jumpOvfl := self JumpOverflow: 0.
objectRepresentation genAddSmallIntegerTagsTo: TempReg.
self MoveR: TempReg R: ReceiverResultReg.
self flag: 'currently caller pushes result'.
+ self RetN: objectMemory wordSize * 2.
- self RetN: BytesPerWord * 2.
jumpOvfl jmpTarget: (jumpNotSI jmpTarget: self Label).
^0!
Item was changed:
----- Method: SimpleStackBasedCogit>>genSend:numArgs: (in category 'bytecode generators') -----
genSend: selector numArgs: numArgs
<inline: false>
(objectMemory isYoung: selector) ifTrue:
[hasYoungReferent := true].
self assert: needsFrame.
self assert: (numArgs between: 0 and: 256). "say"
self assert: (objectMemory addressCouldBeOop: selector).
+ self MoveMw: numArgs * objectMemory wordSize r: SPReg R: ReceiverResultReg.
- self MoveMw: numArgs * BytesPerWord r: SPReg R: ReceiverResultReg.
numArgs > 2 ifTrue:
[self MoveCq: numArgs R: SendNumArgsReg].
self MoveCw: selector R: ClassReg.
self CallSend: (sendTrampolines at: (numArgs min: NumSendTrampolines - 1)).
self flag: 'currently caller pushes result'.
self PushR: ReceiverResultReg.
^0!
Item was changed:
----- Method: SimpleStackBasedCogit>>genSendAbsentDynamicSuper:numArgs: (in category 'bytecode generators') -----
genSendAbsentDynamicSuper: selector numArgs: numArgs
"Shuffle arguments if necessary and push receiver.
Then send."
<inline: false>
numArgs = 0
ifTrue:
[self PushR: ReceiverResultReg]
ifFalse:
[self MoveMw: 0 r: SPReg R: TempReg.
self PushR: TempReg.
2 to: numArgs do:
[:index|
+ self MoveMw: index * objectMemory wordSize r: SPReg R: TempReg.
+ self MoveR: TempReg Mw: index - 1 * objectMemory wordSize r: SPReg].
- self MoveMw: index * BytesPerWord r: SPReg R: TempReg.
- self MoveR: TempReg Mw: index - 1 * BytesPerWord r: SPReg].
"if we copied the code in genSendDynamicSuper: we could save an instruction.
But we care not; the smarts are in StackToRegisterMappingCogit et al"
+ self MoveR: ReceiverResultReg Mw: numArgs * objectMemory wordSize r: SPReg].
- self MoveR: ReceiverResultReg Mw: numArgs * BytesPerWord r: SPReg].
^self genSendDynamicSuper: selector numArgs: numArgs!
Item was changed:
----- Method: SimpleStackBasedCogit>>genSendAbsentImplicit:numArgs: (in category 'bytecode generators') -----
genSendAbsentImplicit: selector numArgs: numArgs
"Get the implicit receiver and shuffle arguments if necessary.
Then send."
<inline: false>
| result |
result := self genGetImplicitReceiverFor: selector forPush: false.
result ~= 0 ifTrue:
[^result].
numArgs = 0
ifTrue:
[self PushR: ReceiverResultReg]
ifFalse:
[self MoveMw: 0 r: SPReg R: TempReg.
self PushR: TempReg.
2 to: numArgs do:
[:index|
+ self MoveMw: index * objectMemory wordSize r: SPReg R: TempReg.
+ self MoveR: TempReg Mw: index - 1 * objectMemory wordSize r: SPReg].
- self MoveMw: index * BytesPerWord r: SPReg R: TempReg.
- self MoveR: TempReg Mw: index - 1 * BytesPerWord r: SPReg].
"if we copied the code in genSend:numArgs: we could save an instruction.
But we care not; the smarts are in StackToRegisterMappingCogit et al"
+ self MoveR: ReceiverResultReg Mw: numArgs * objectMemory wordSize r: SPReg].
- self MoveR: ReceiverResultReg Mw: numArgs * BytesPerWord r: SPReg].
^self genSend: selector numArgs: numArgs!
Item was changed:
----- Method: SimpleStackBasedCogit>>genSendDynamicSuper:numArgs: (in category 'bytecode generators') -----
genSendDynamicSuper: selector numArgs: numArgs
(objectMemory isYoung: selector) ifTrue:
[hasYoungReferent := true].
self assert: needsFrame.
+ self MoveMw: numArgs * objectMemory wordSize r: SPReg R: ReceiverResultReg.
- self MoveMw: numArgs * BytesPerWord r: SPReg R: ReceiverResultReg.
numArgs > 2 ifTrue:
[self MoveCq: numArgs R: SendNumArgsReg].
self MoveCw: selector R: ClassReg.
self CallSend: (dynamicSuperSendTrampolines at: (numArgs min: NumSendTrampolines - 1)).
self flag: 'currently caller pushes result'.
self PushR: ReceiverResultReg.
^0!
Item was changed:
----- Method: SimpleStackBasedCogit>>genSendSuper:numArgs: (in category 'bytecode generators') -----
genSendSuper: selector numArgs: numArgs
<inline: false>
self assert: needsFrame.
self assert: (numArgs between: 0 and: 256). "say"
self assert: (objectMemory addressCouldBeOop: selector).
(objectMemory isYoung: selector) ifTrue:
[hasYoungReferent := true].
+ self MoveMw: numArgs * objectMemory wordSize r: SPReg R: ReceiverResultReg.
- self MoveMw: numArgs * BytesPerWord r: SPReg R: ReceiverResultReg.
numArgs > 2 ifTrue:
[self MoveCq: numArgs R: SendNumArgsReg].
self MoveCw: selector R: ClassReg.
self CallSend: (superSendTrampolines at: (numArgs min: NumSendTrampolines - 1)).
self flag: 'currently caller pushes result'.
self PushR: ReceiverResultReg.
^0!
Item was changed:
----- Method: SimpleStackBasedCogit>>genSmallIntegerComparison: (in category 'primitive generators') -----
genSmallIntegerComparison: jumpOpcode
"Stack looks like
receiver (also in ResultReceiverReg)
arg
return address"
| jumpFail jumpTrue |
<var: #jumpFail type: #'AbstractInstruction *'>
<var: #jumpTrue type: #'AbstractInstruction *'>
+ self MoveMw: objectMemory wordSize r: SPReg R: TempReg.
- self MoveMw: BytesPerWord r: SPReg R: TempReg.
self MoveR: TempReg R: ClassReg.
jumpFail := objectRepresentation genJumpNotSmallIntegerInScratchReg: TempReg.
self CmpR: ClassReg R: ReceiverResultReg. "N.B. FLAGS := RRReg - ClassReg"
jumpTrue := self gen: jumpOpcode.
self annotate: (self MoveCw: objectMemory falseObject R: ReceiverResultReg)
objRef: objectMemory falseObject.
self flag: 'currently caller pushes result'.
+ self RetN: objectMemory wordSize * 2.
- self RetN: BytesPerWord * 2.
jumpTrue jmpTarget: (self annotate: (self MoveCw: objectMemory trueObject R: ReceiverResultReg)
objRef: objectMemory trueObject).
+ self RetN: objectMemory wordSize * 2.
- self RetN: BytesPerWord * 2.
jumpFail jmpTarget: self Label.
^0!
Item was changed:
----- Method: SimpleStackBasedCogit>>genSmallIntegerComparison:orDoubleComparison: (in category 'primitive generators') -----
genSmallIntegerComparison: jumpOpcode orDoubleComparison: jumpFPOpcodeGenerator
"Stack looks like
receiver (also in ResultReceiverReg)
arg
return address"
| jumpDouble jumpNonInt jumpFail jumpTrue jumpCond |
<var: #jumpFPOpcodeGenerator declareC: 'AbstractInstruction *(*jumpFPOpcodeGenerator)(void *)'>
<var: #jumpDouble type: #'AbstractInstruction *'>
<var: #jumpNonInt type: #'AbstractInstruction *'>
<var: #jumpCond type: #'AbstractInstruction *'>
<var: #jumpTrue type: #'AbstractInstruction *'>
<var: #jumpFail type: #'AbstractInstruction *'>
backEnd hasDoublePrecisionFloatingPointSupport ifFalse:
[^self genSmallIntegerComparison: jumpOpcode].
+ self MoveMw: objectMemory wordSize r: SPReg R: TempReg.
- self MoveMw: BytesPerWord r: SPReg R: TempReg.
self MoveR: TempReg R: ClassReg.
jumpDouble := objectRepresentation genJumpNotSmallIntegerInScratchReg: TempReg.
self CmpR: ClassReg R: ReceiverResultReg. "N.B. FLAGS := RRReg - ClassReg"
jumpTrue := self gen: jumpOpcode.
self annotate: (self MoveCw: objectMemory falseObject R: ReceiverResultReg)
objRef: objectMemory falseObject.
self flag: 'currently caller pushes result'.
+ self RetN: objectMemory wordSize * 2.
- self RetN: BytesPerWord * 2.
jumpTrue jmpTarget: (self annotate: (self MoveCw: objectMemory trueObject R: ReceiverResultReg)
objRef: objectMemory trueObject).
+ self RetN: objectMemory wordSize * 2.
- self RetN: BytesPerWord * 2.
"Argument may be a Float : let us check or fail"
jumpDouble jmpTarget: self Label.
objectRepresentation smallIntegerIsOnlyImmediateType ifFalse:
[self MoveR: ClassReg R: TempReg.
jumpNonInt := objectRepresentation genJumpImmediateInScratchReg: TempReg].
objectRepresentation genGetCompactClassIndexNonImmOf: ClassReg into: SendNumArgsReg.
objectRepresentation genCmpClassFloatCompactIndexR: SendNumArgsReg.
jumpFail := self JumpNonZero: 0.
"It was a Float, so convert the receiver to double and perform the operation"
self MoveR: ReceiverResultReg R: TempReg.
objectRepresentation genConvertSmallIntegerToIntegerInReg: TempReg.
self ConvertR: TempReg Rd: DPFPReg0.
objectRepresentation genGetDoubleValueOf: ClassReg into: DPFPReg1.
self CmpRd: DPFPReg1 Rd: DPFPReg0.
jumpCond := self perform: jumpFPOpcodeGenerator with: 0. "FP jumps are a little weird"
self annotate: (self MoveCw: objectMemory falseObject R: ReceiverResultReg)
objRef: objectMemory falseObject.
self flag: 'currently caller pushes result'.
+ self RetN: objectMemory wordSize * 2.
- self RetN: BytesPerWord * 2.
jumpCond jmpTarget: (self annotate: (self MoveCw: objectMemory trueObject R: ReceiverResultReg)
objRef: objectMemory trueObject).
+ self RetN: objectMemory wordSize * 2.
- self RetN: BytesPerWord * 2.
objectRepresentation smallIntegerIsOnlyImmediateType
ifTrue: [jumpFail jmpTarget: self Label]
ifFalse: [jumpNonInt jmpTarget: (jumpFail jmpTarget: self Label)].
^0!
Item was changed:
----- Method: SimpleStackBasedCogit>>genStorePop:MaybeContextReceiverVariable: (in category 'bytecode generators') -----
genStorePop: popBoolean MaybeContextReceiverVariable: slotIndex
<inline: false>
| jmpSingle jmpDone |
<var: #jmpSingle type: #'AbstractInstruction *'>
<var: #jmpDone type: #'AbstractInstruction *'>
self assert: needsFrame.
self MoveMw: FoxMFReceiver r: FPReg R: ReceiverResultReg.
objectRepresentation
genLoadSlot: SenderIndex
sourceReg: ReceiverResultReg
destReg: TempReg.
self MoveMw: 0 r: SPReg R: ClassReg.
jmpSingle := objectRepresentation genJumpNotSmallIntegerInScratchReg: TempReg.
self MoveCq: slotIndex R: SendNumArgsReg.
self CallRT: ceStoreContextInstVarTrampoline.
jmpDone := self Jump: 0.
jmpSingle jmpTarget: self Label.
traceStores > 0 ifTrue:
[self CallRT: ceTraceStoreTrampoline].
objectRepresentation
genStoreSourceReg: ClassReg
slotIndex: slotIndex
destReg: ReceiverResultReg
scratchReg: TempReg.
jmpDone jmpTarget: self Label.
popBoolean ifTrue:
+ [self AddCq: objectMemory wordSize R: SPReg].
- [self AddCq: BytesPerWord R: SPReg].
^0!
Item was changed:
----- Method: SimpleStackBasedCogit>>genUpArrowReturn (in category 'bytecode generators') -----
genUpArrowReturn
"Generate a method return from within a method or a block.
Frameless method activation looks like
receiver
args
sp-> ret pc.
Return pops receiver and arguments off the stack. Callee pushes the result."
self flag: 'currently caller pushes result'.
inBlock ifTrue:
[self assert: needsFrame.
self annotateBytecode: (self CallRT: ceNonLocalReturnTrampoline).
^0].
needsFrame ifTrue:
[self MoveR: FPReg R: SPReg.
self PopR: FPReg].
backEnd hasLinkRegister ifTrue:
[self PopR: LinkReg].
+ self RetN: methodOrBlockNumArgs + 1 * objectMemory wordSize.
- self RetN: methodOrBlockNumArgs + 1 * BytesPerWord.
^0!
Item was changed:
----- Method: SistaStackToRegisterMappingCogit>>genJumpIf:to: (in category 'bytecode generators') -----
genJumpIf: boolean to: targetBytecodePC
"The heart of performance counting in Sista. Conditional branches are 6 times less
frequent than sends and can provide basic block frequencies (send counters can't).
Each conditional has a 32-bit counter split into an upper 16 bits counting executions
and a lower half counting untaken executions of the branch. Executing the branch
decrements the upper half, tripping if the count goes negative. Not taking the branch
decrements the lower half. N.B. We *do not* eliminate dead branches (true ifTrue:/true ifFalse:)
so that scanning for send and branch data is simplified and that branch data is correct."
<inline: false>
| desc ok counterAddress countTripped retry |
<var: #ok type: #'AbstractInstruction *'>
<var: #desc type: #'CogSimStackEntry *'>
<var: #retry type: #'AbstractInstruction *'>
<var: #countTripped type: #'AbstractInstruction *'>
self ssFlushTo: simStackPtr - 1.
desc := self ssTop.
self ssPop: 1.
desc popToReg: TempReg.
self ssAllocateRequiredReg: SendNumArgsReg. "Use this as the count reg."
counterAddress := counters + ((self sizeof: #sqInt) * counterIndex).
counterIndex := counterIndex + 1.
self flag: 'will need to use MoveAw32:R: if 64 bits'.
+ self assert: objectMemory wordSize = CounterBytes.
- self assert: BytesPerWord = CounterBytes.
retry := self MoveAw: counterAddress R: SendNumArgsReg.
self SubCq: 16r10000 R: SendNumArgsReg. "Count executed"
"Don't write back if we trip; avoids wrapping count back to initial value, and if we trip we don't execute."
countTripped := self JumpCarry: 0.
self MoveR: SendNumArgsReg Aw: counterAddress. "write back"
"Cunning trick by LPD. If true and false are contiguous subtract the smaller.
Correct result is either 0 or the distance between them. If result is not 0 or
their distance send mustBeBoolean."
self assert: (objectMemory objectAfter: objectMemory falseObject) = objectMemory trueObject.
self annotate: (self SubCw: boolean R: TempReg) objRef: boolean.
self JumpZero: (self ensureFixupAt: targetBytecodePC - initialPC).
self SubCq: 1 R: SendNumArgsReg. "Count untaken"
self MoveR: SendNumArgsReg Aw: counterAddress. "write back"
self CmpCq: (boolean == objectMemory falseObject
ifTrue: [objectMemory trueObject - objectMemory falseObject]
ifFalse: [objectMemory falseObject - objectMemory trueObject])
R: TempReg.
ok := self JumpZero: 0.
self MoveCq: 0 R: SendNumArgsReg. "if SendNumArgsReg is 0 this is a mustBeBoolean, not a counter trip."
countTripped jmpTarget:
(self CallRT: (boolean == objectMemory falseObject
ifTrue: [ceSendMustBeBooleanAddFalseTrampoline]
ifFalse: [ceSendMustBeBooleanAddTrueTrampoline])).
"If we're in an image which hasn't got the Sista code loaded then the ceCounterTripped:
trampoline will return directly to machine code, returning the boolean. So the code should
jump back to the retry point. The trampoline makes sure that TempReg has been reloaded."
self annotateBytecode: self Label.
self Jump: retry.
ok jmpTarget: self Label.
^0!
Item was changed:
----- Method: SistaStackToRegisterMappingCogit>>genSpecialSelectorComparison (in category 'bytecode generators') -----
genSpecialSelectorComparison
"Override to count inlined branches if followed by a conditional branch.
We borrow the following conditional branch's counter and when about to
inline the comparison we decrement the counter (without writing it back)
and if it trips simply abort the inlining, falling back to the normal send which
will then continue to the conditional branch which will trip and enter the abort."
| nextPC postBranchPC targetBytecodePC primDescriptor branchDescriptor nExts
rcvrIsInt argIsInt rcvrInt argInt result jumpNotSmallInts inlineCAB annotateInst
counterAddress countTripped |
<var: #countTripped type: #'AbstractInstruction *'>
<var: #primDescriptor type: #'BytecodeDescriptor *'>
<var: #jumpNotSmallInts type: #'AbstractInstruction *'>
<var: #branchDescriptor type: #'BytecodeDescriptor *'>
self ssFlushTo: simStackPtr - 2.
primDescriptor := self generatorAt: byte0.
argIsInt := self ssTop type = SSConstant
and: [objectMemory isIntegerObject: (argInt := self ssTop constant)].
rcvrIsInt := (self ssValue: 1) type = SSConstant
and: [objectMemory isIntegerObject: (rcvrInt := (self ssValue: 1) constant)].
"short-cut the jump if operands are SmallInteger constants."
(argIsInt and: [rcvrIsInt]) ifTrue:
[self cCode: '' inSmalltalk: "In Simulator ints are unsigned..."
[rcvrInt := objectMemory integerValueOf: rcvrInt.
argInt := objectMemory integerValueOf: argInt].
primDescriptor opcode caseOf: {
[JumpLess] -> [result := rcvrInt < argInt].
[JumpLessOrEqual] -> [result := rcvrInt <= argInt].
[JumpGreater] -> [result := rcvrInt > argInt].
[JumpGreaterOrEqual] -> [result := rcvrInt >= argInt].
[JumpZero] -> [result := rcvrInt = argInt].
[JumpNonZero] -> [result := rcvrInt ~= argInt] }.
"Must enter any annotatedConstants into the map"
self annotateBytecodeIfAnnotated: (self ssValue: 1).
self annotateBytecodeIfAnnotated: self ssTop.
"Must annotate the bytecode for correct pc mapping."
self ssPop: 2.
^self ssPushAnnotatedConstant: (result
ifTrue: [objectMemory trueObject]
ifFalse: [objectMemory falseObject])].
nextPC := bytecodePC + primDescriptor numBytes.
nExts := 0.
[branchDescriptor := self generatorAt: (objectMemory fetchByte: nextPC ofObject: methodObj) + (byte0 bitAnd: 256).
branchDescriptor isExtension] whileTrue:
[nExts := nExts + 1.
nextPC := nextPC + branchDescriptor numBytes].
"Only interested in inlining if followed by a conditional branch."
inlineCAB := branchDescriptor isBranchTrue or: [branchDescriptor isBranchFalse].
"Further, only interested in inlining = and ~= if there's a SmallInteger constant involved.
The relational operators successfully statically predict SmallIntegers; the equality operators do not."
(inlineCAB and: [primDescriptor opcode = JumpZero or: [primDescriptor opcode = JumpNonZero]]) ifTrue:
[inlineCAB := argIsInt or: [rcvrIsInt]].
inlineCAB ifFalse:
[^self genSpecialSelectorSend].
targetBytecodePC := nextPC
+ branchDescriptor numBytes
+ (self spanFor: branchDescriptor at: nextPC exts: nExts in: methodObj).
postBranchPC := nextPC + branchDescriptor numBytes.
argIsInt
ifTrue:
[(self ssValue: 1) popToReg: ReceiverResultReg.
annotateInst := self ssTop annotateUse.
self ssPop: 2.
self MoveR: ReceiverResultReg R: TempReg]
ifFalse:
[self marshallSendArguments: 1.
self MoveR: Arg0Reg R: TempReg.
rcvrIsInt ifFalse:
[objectRepresentation isSmallIntegerTagNonZero
ifTrue: [self AndR: ReceiverResultReg R: TempReg]
ifFalse: [self OrR: ReceiverResultReg R: TempReg]]].
jumpNotSmallInts := objectRepresentation genJumpNotSmallIntegerInScratchReg: TempReg.
self ssAllocateRequiredReg: SendNumArgsReg. "Use this as the count reg."
counterAddress := counters + ((self sizeof: #sqInt) * counterIndex).
self flag: 'will need to use MoveAw32:R: if 64 bits'.
+ self assert: objectMemory wordSize = CounterBytes.
- self assert: BytesPerWord = CounterBytes.
self MoveAw: counterAddress R: SendNumArgsReg.
self SubCq: 16r10000 R: SendNumArgsReg. "Count executed"
"If counter trips simply abort the inlined comparison and send continuing to the following
branch *without* writing back. A double decrement will not trip the second time."
countTripped := self JumpCarry: 0.
self MoveR: SendNumArgsReg Aw: counterAddress. "write back"
argIsInt
ifTrue: [annotateInst
ifTrue: [self annotateBytecode: (self CmpCq: argInt R: ReceiverResultReg)]
ifFalse: [self CmpCq: argInt R: ReceiverResultReg]]
ifFalse: [self CmpR: Arg0Reg R: ReceiverResultReg].
"Cmp is weird/backwards so invert the comparison. Further since there is a following conditional
jump bytecode define non-merge fixups and leave the cond bytecode to set the mergeness."
self gen: (branchDescriptor isBranchTrue
ifTrue: [primDescriptor opcode]
ifFalse: [self inverseBranchFor: primDescriptor opcode])
operand: (self ensureNonMergeFixupAt: targetBytecodePC - initialPC) asUnsignedInteger.
self SubCq: 1 R: SendNumArgsReg. "Count untaken"
self MoveR: SendNumArgsReg Aw: counterAddress. "write back"
self Jump: (self ensureNonMergeFixupAt: postBranchPC - initialPC).
countTripped jmpTarget: (jumpNotSmallInts jmpTarget: self Label).
argIsInt ifTrue:
[self MoveCq: argInt R: Arg0Reg].
^self genMarshalledSend: (coInterpreter specialSelector: byte0 - self firstSpecialSelectorBytecodeOffset)
numArgs: 1!
Item was changed:
----- Method: SistaStackToRegisterMappingCogit>>genSpecialSelectorEqualsEquals (in category 'bytecode generators') -----
genSpecialSelectorEqualsEquals
"Override to count inlined branches if followed by a conditional branch.
We borrow the following conditional branch's counter and when about to
inline the comparison we decrement the counter (without writing it back)
and if it trips simply abort the inlining, falling back to the normal send which
will then continue to the conditional branch which will trip and enter the abort."
| nextPC postBranchPC targetBytecodePC primDescriptor branchDescriptor nExts
counterAddress countTripped unforwardArg unforwardRcvr |
<var: #countTripped type: #'AbstractInstruction *'>
<var: #primDescriptor type: #'BytecodeDescriptor *'>
<var: #branchDescriptor type: #'BytecodeDescriptor *'>
self ssFlushTo: simStackPtr - 2.
primDescriptor := self generatorAt: byte0.
nextPC := bytecodePC + primDescriptor numBytes.
nExts := 0.
[branchDescriptor := self generatorAt: (objectMemory fetchByte: nextPC ofObject: methodObj) + (byte0 bitAnd: 256).
branchDescriptor isExtension] whileTrue:
[nExts := nExts + 1.
nextPC := nextPC + branchDescriptor numBytes].
"Only interested in inlining if followed by a conditional branch."
(branchDescriptor isBranchTrue or: [branchDescriptor isBranchFalse]) ifFalse:
[^self genSpecialSelectorSend].
targetBytecodePC := nextPC
+ branchDescriptor numBytes
+ (self spanFor: branchDescriptor at: nextPC exts: nExts in: methodObj).
postBranchPC := nextPC + branchDescriptor numBytes.
unforwardRcvr := (self ssValue: 1) type ~= SSConstant
or: [objectRepresentation shouldAnnotateObjectReference: (self ssValue: 1) constant].
unforwardArg := self ssTop type ~= SSConstant
or: [objectRepresentation shouldAnnotateObjectReference: self ssTop constant].
self marshallSendArguments: 1.
self ssAllocateRequiredReg: SendNumArgsReg. "Use this as the count reg."
counterAddress := counters + ((self sizeof: #sqInt) * counterIndex).
self flag: 'will need to use MoveAw32:R: if 64 bits'.
+ self assert: objectMemory wordSize = CounterBytes.
- self assert: BytesPerWord = CounterBytes.
self MoveAw: counterAddress R: SendNumArgsReg.
self SubCq: 16r10000 R: SendNumArgsReg. "Count executed"
"If counter trips simply abort the inlined comparison and send continuing to the following
branch *without* writing back. A double decrement will not trip the second time."
countTripped := self JumpCarry: 0.
self MoveR: SendNumArgsReg Aw: counterAddress. "write back"
unforwardRcvr ifTrue:
[objectRepresentation genEnsureOopInRegNotForwarded: ReceiverResultReg scratchReg: TempReg].
unforwardArg ifTrue:
[objectRepresentation genEnsureOopInRegNotForwarded: Arg0Reg scratchReg: TempReg].
self CmpR: Arg0Reg R: ReceiverResultReg.
"Cmp is weird/backwards so invert the comparison. Further since there is a following conditional
jump bytecode define non-merge fixups and leave the cond bytecode to set the mergeness."
self gen: (branchDescriptor isBranchTrue ifTrue: [JumpZero] ifFalse: [JumpNonZero])
operand: (self ensureNonMergeFixupAt: targetBytecodePC - initialPC) asUnsignedInteger.
self SubCq: 1 R: SendNumArgsReg. "Count untaken"
self MoveR: SendNumArgsReg Aw: counterAddress. "write back"
self Jump: (self ensureNonMergeFixupAt: postBranchPC - initialPC).
countTripped jmpTarget: self Label.
^self genMarshalledSend: (coInterpreter specialSelector: byte0 - self firstSpecialSelectorBytecodeOffset)
numArgs: 1!
Item was changed:
----- Method: SistaStackToRegisterMappingCogit>>initialize (in category 'initialization') -----
initialize
super initialize.
+ cogMethodSurrogateClass := objectMemory wordSize = 4
- cogMethodSurrogateClass := BytesPerWord = 4
ifTrue: [CogSistaMethodSurrogate32]
ifFalse: [CogSistaMethodSurrogate64]!
Item was changed:
----- Method: SmartSyntaxPluginTMethod>>setSelector:definingClass:args:locals:block:primitive:properties:comment: (in category 'initializing') -----
setSelector: sel definingClass: class args: argList locals: localList block: aBlockNode primitive: aNumber properties: methodProperties comment: aComment
"Initialize this method using the given information."
selector := sel.
definingClass := class.
returnType := #sqInt. "assume return type is sqInt for now"
args := argList asOrderedCollection collect: [:arg | arg key].
locals := (localList collect: [:arg | arg key]) asSet.
declarations := Dictionary new.
primitive := aNumber.
properties := methodProperties.
comment := aComment.
parseTree := aBlockNode asTranslatorNodeIn: self.
labels := Set new.
complete := false. "set to true when all possible inlining has been done"
export := self extractExportDirective.
static := self extractStaticDirective.
- canAsmLabel := self extractLabelDirective.
self extractSharedCase.
isPrimitive := false. "set to true only if you find a primtive direction."
suppressingFailureGuards := self extractSuppressFailureGuardDirective.
self recordDeclarationsIn: nil.
self extractPrimitiveDirectives.
!
Item was changed:
----- Method: SoundCodecPlugin>>primitiveGSMNewState (in category 'gsm 6.10 codec') -----
primitiveGSMNewState
| state |
<export: true>
state := interpreterProxy
instantiateClass: interpreterProxy classByteArray
indexableSize: self gsmStateBytes.
+ self gsmInitState: state + interpreterProxy baseHeaderSize.
- self gsmInitState: state + BaseHeaderSize.
interpreterProxy pop: 1 thenPush: state!
Item was removed:
- ----- Method: Spur32BitMemoryManager>>bytesPerSlot (in category 'header format') -----
- bytesPerSlot
- ^4!
Item was changed:
----- Method: Spur32BitMemoryManager>>fillObj:numSlots:with: (in category 'instantiation') -----
fillObj: objOop numSlots: numSlots with: fillValue
<inline: true>
<var: #p type: #usqInt>
+ self assert: (self oop: objOop + self baseHeaderSize + (numSlots * self bytesPerOop) - 1
- self assert: (self oop: objOop + self baseHeaderSize + (numSlots * self bytesPerSlot) - 1
isLessThan: (self addressAfter: objOop)).
(objOop + self baseHeaderSize) asUnsignedInteger
+ to: (objOop + self baseHeaderSize + (numSlots * self bytesPerOop) - 1) asUnsignedInteger
- to: (objOop + self baseHeaderSize + (numSlots * self bytesPerSlot) - 1) asUnsignedInteger
by: self allocationUnit
do: [:p|
self longAt: p put: fillValue;
longAt: p + 4 put: fillValue]!
Item was changed:
----- Method: Spur32BitMemoryManager>>initFreeChunkWithBytes:at: (in category 'free space') -----
initFreeChunkWithBytes: numBytes at: address
<var: #numBytes type: #usqLong>
| numSlots |
"must have room for a header (single or double) plus the next free pointer"
self assert: (numBytes \\ self allocationUnit = 0
+ and: [numBytes >= (self baseHeaderSize + self bytesPerOop)]).
- and: [numBytes >= (self baseHeaderSize + self bytesPerSlot)]).
self flag: #endianness.
"double header"
numBytes >= ((self numSlotsMask << self shiftForWord) + self baseHeaderSize) ifTrue:
[numSlots := numBytes - self baseHeaderSize - self baseHeaderSize >> self shiftForWord.
self longAt: address put: numSlots;
longAt: address + 4 put: self numSlotsMask << self numSlotsHalfShift;
longAt: address + 8 put: 0; "0's classIndex; 0 = classIndex of free chunks"
longAt: address + 12 put: self numSlotsMask << self numSlotsHalfShift.
^address + 8].
"single header"
numSlots := numBytes - self baseHeaderSize >> self shiftForWord.
self assert: numSlots < self numSlotsMask.
self longAt: address put: 0; "0's classIndex; 0 = classIndex of free chunks"
longAt: address + 4 put: numSlots << self numSlotsHalfShift.
^address!
Item was changed:
----- Method: Spur32BitMemoryManager>>largeObjectBytesForSlots: (in category 'allocation') -----
largeObjectBytesForSlots: numSlots
"Answer the total number of bytes in an object with an overflow header, including header bytes."
<returnTypeC: #usqInt>
^self baseHeaderSize + self baseHeaderSize "double header"
+ + (numSlots + (numSlots bitAnd: 1) * self bytesPerOop) "roundTo allocationUnit"!
- + (numSlots + (numSlots bitAnd: 1) * self bytesPerSlot) "roundTo allocationUnit"!
Item was changed:
----- Method: Spur32BitMemoryManager>>shiftForWord (in category 'word size') -----
shiftForWord
<api>
+ <cmacro: '() 2'>
^2!
Item was changed:
----- Method: Spur32BitMemoryManager>>smallObjectBytesForSlots: (in category 'allocation') -----
smallObjectBytesForSlots: numSlots
"Answer the total number of bytes in an object without an overflow header, including header bytes."
<api>
<returnTypeC: #usqInt>
^self baseHeaderSize "single header"
+ (numSlots <= 1
ifTrue: [self allocationUnit] "at least one slot for the forwarding pointer"
+ ifFalse: [numSlots + (numSlots bitAnd: 1) * self bytesPerOop]) "round up to allocationUnit"!
- ifFalse: [numSlots + (numSlots bitAnd: 1) * self bytesPerSlot]) "round up to allocationUnit"!
Item was removed:
- ----- Method: Spur64BitMemoryManager>>bytesPerSlot (in category 'accessing') -----
- bytesPerSlot
- ^8!
Item was changed:
----- Method: Spur64BitMemoryManager>>fillObj:numSlots:with: (in category 'instantiation') -----
fillObj: objOop numSlots: numSlots with: fillValue
<inline: true>
<var: #p type: #usqInt>
+ self assert: (self oop: objOop + self baseHeaderSize + (numSlots * self bytesPerOop) - 1
- self assert: (self oop: objOop + self baseHeaderSize + (numSlots * self bytesPerSlot) - 1
isLessThan: (self addressAfter: objOop)).
(objOop + self baseHeaderSize) asUnsignedInteger
+ to: (objOop + self baseHeaderSize + (numSlots * self bytesPerOop) - 1) asUnsignedInteger
- to: (objOop + self baseHeaderSize + (numSlots * self bytesPerSlot) - 1) asUnsignedInteger
by: self allocationUnit
do: [:p| self longAt: p put: fillValue]!
Item was changed:
----- Method: Spur64BitMemoryManager>>initFreeChunkWithBytes:at: (in category 'free space') -----
initFreeChunkWithBytes: numBytes at: address
<var: #numBytes type: #usqLong>
| numSlots |
"must have room for a header (single or double) plus the next free pointer"
self assert: (numBytes \\ self allocationUnit = 0
+ and: [numBytes >= (self baseHeaderSize + self bytesPerOop)]).
- and: [numBytes >= (self baseHeaderSize + self bytesPerSlot)]).
"double header"
numBytes >= ((self numSlotsMask << self shiftForWord) + self baseHeaderSize) ifTrue:
[numSlots := numBytes - self baseHeaderSize - self baseHeaderSize >> self shiftForWord.
self longAt: address put: self numSlotsMask << self numSlotsFullShift + numSlots;
longAt: address + 8 put: self numSlotsMask << self numSlotsFullShift. "0's classIndex; 0 = classIndex of free chunks"
^address + 8].
"single header"
numSlots := numBytes - self baseHeaderSize >> self shiftForWord.
self assert: numSlots < self numSlotsMask.
self longAt: address put: numSlots << self numSlotsFullShift. "0's classIndex; 0 = classIndex of free chunks"
^address!
Item was changed:
----- Method: Spur64BitMemoryManager>>largeObjectBytesForSlots: (in category 'allocation') -----
largeObjectBytesForSlots: numSlots
"Answer the total number of bytes in an object with an overflow header, including header bytes."
<returnTypeC: #usqInt>
^self baseHeaderSize + self baseHeaderSize "double header"
+ + (numSlots * self bytesPerOop) "no rounding; bytesPerOop = allocationUnit"!
- + (numSlots * self bytesPerSlot) "no rounding; bytesPerSlot = allocationUnit"!
Item was changed:
----- Method: Spur64BitMemoryManager>>shiftForWord (in category 'word size') -----
shiftForWord
<api>
+ <cmacro: '() 3'>
^3!
Item was changed:
----- Method: Spur64BitMemoryManager>>smallObjectBytesForSlots: (in category 'allocation') -----
smallObjectBytesForSlots: numSlots
"Answer the total number of bytes in an object without an overflow header, including header bytes."
<returnTypeC: #usqInt>
^self baseHeaderSize "single header"
+ (numSlots < 1
ifTrue: [self allocationUnit] "at least one slot for the forwarding pointer"
+ ifFalse: [numSlots * self bytesPerOop])!
- ifFalse: [numSlots * self bytesPerSlot])!
Item was changed:
----- Method: SpurMemoryManager class>>initBytesPerWord: (in category 'class initialization') -----
initBytesPerWord: nBytes
BytesPerWord := nBytes.
- ShiftForWord := (BytesPerWord log: 2) rounded.
"The following is necessary to avoid confusing the compiler with shifts that are larger than the width of the type on which they operate. In gcc, such shifts cause incorrect code to be generated."
BytesPerWord = 8
ifTrue: "64-bit VM"
[Byte0Mask := 16r00000000000000FF. Byte0Shift := 0.
Byte1Mask := 16r000000000000FF00. Byte1Shift := 8.
Byte2Mask := 16r0000000000FF0000. Byte2Shift := 16.
Byte3Mask := 16r00000000FF000000. Byte3Shift := 24.
Byte4Mask := 16r000000FF00000000. Byte4Shift := 32.
Byte5Mask := 16r0000FF0000000000. Byte5Shift := 40.
Byte6Mask := 16r00FF000000000000. Byte6Shift := 48.
Byte7Mask := 16rFF00000000000000. Byte7Shift := 56.
Bytes3to0Mask := 16r00000000FFFFFFFF.
Bytes7to4Mask := 16rFFFFFFFF00000000]
ifFalse: "32-bit VM"
[Byte0Mask := 16r00000000000000FF. Byte0Shift := 0.
Byte1Mask := 16r000000000000FF00. Byte1Shift := 8.
Byte2Mask := 16r0000000000FF0000. Byte2Shift := 16.
Byte3Mask := 16r00000000FF000000. Byte3Shift := 24.
Byte4Mask := nil. Byte4Shift := 0. "unused"
Byte5Mask := nil. Byte5Shift := 0. "unused"
Byte6Mask := nil. Byte6Shift := 0. "unused"
Byte7Mask := nil. Byte7Shift := 0. "unused"
Bytes3to0Mask := nil. "unused"
Bytes7to4Mask := nil "unused"].
Byte1ShiftNegated := Byte1Shift negated.
Byte3ShiftNegated := Byte3Shift negated.
Byte4ShiftNegated := Byte4Shift negated.
Byte5ShiftNegated := Byte5Shift negated.
Byte7ShiftNegated := Byte7Shift negated.
"N.B. This is *not* output when generating the interpreter file.
It is left to the various sqConfig.h files to define correctly."
VMBIGENDIAN := Smalltalk endianness == #big!
Item was changed:
----- Method: SpurMemoryManager class>>initializeObjectHeaderConstants (in category 'class initialization') -----
initializeObjectHeaderConstants
+ BytesPerWord ifNil: [BytesPerWord := 4] "May get called on fileIn, so supply default"!
- BytesPerWord ifNil: [BytesPerWord := 4]. "May get called on fileIn, so supply default"
- BaseHeaderSize := 8 "Alas so much of the VM uses BaseheaderSize explicitly we don't (yet) make it a message."!
Item was changed:
----- Method: SpurMemoryManager class>>initializeWithOptions: (in category 'class initialization') -----
initializeWithOptions: optionsDictionary
"SpurMemoryManager initializeWithOptions: Dictionary new"
super initializeWithOptions: optionsDictionary.
self initialize.
self initBytesPerWord: (self == SpurMemoryManager
ifTrue: [optionsDictionary at: #BytesPerWord ifAbsent: [4]]
ifFalse: [self wordSize]).
- BytesPerOop := optionsDictionary at: #BytesPerOop ifAbsent: [BytesPerWord].
self initializeObjectHeaderConstants. "Initializes BaseHeaderSize so do early"
self initializeSpurObjectRepresentationConstants.
self initializeSpecialObjectIndices.
self initializeCompactClassIndices.
self initializePrimitiveErrorCodes.
SpurGenerationScavenger initialize!
Item was changed:
----- Method: SpurMemoryManager>>allInstancesOf: (in category 'primitive support') -----
allInstancesOf: aClass
"Attempt to answer an array of all objects, excluding those that may
be garbage collected as a side effect of allocating the result array.
If no memory is available answer the number of instances as a SmallInteger.
Since objects are at least 16 bytes big, and the largest SmallInteger covers
1/4 of the address space, the count can never overflow."
| classIndex freeChunk ptr start limit count bytes |
classIndex := self rawHashBitsOf: aClass.
classIndex = 0 ifTrue:
[freeChunk := self allocateSlots: 0 format: self arrayFormat classIndex: ClassArrayCompactIndex.
^freeChunk].
MarkObjectsForEnumerationPrimitives ifTrue:
[self markObjects: true]. "may not want to revive objects unnecessarily; but marking is sloooow."
freeChunk := self allocateLargestFreeChunk.
start := freeChunk + self baseHeaderSize.
limit := self addressAfter: freeChunk.
(self isClassAtUniqueIndex: aClass)
ifTrue:
[self uniqueIndex: classIndex allInstancesInto: start limit: limit resultsInto: [:c :p| count := c. ptr := p]]
ifFalse:
[self ambiguousClass: aClass allInstancesInto: start limit: limit resultsInto: [:c :p| count := c. ptr := p]].
self assert: (self isEmptyObjStack: markStack).
MarkObjectsForEnumerationPrimitives
ifTrue:
[self assert: self allObjectsUnmarked.
self emptyObjStack: weaklingStack]
ifFalse:
[self assert: (self isEmptyObjStack: weaklingStack)].
+ (count > (ptr - start / self bytesPerOop) "not enough room"
- (count > (ptr - start / self bytesPerSlot) "not enough room"
or: [limit ~= ptr and: [limit - ptr <= self allocationUnit]]) ifTrue: "can't split a single word"
[self freeObject: freeChunk.
^self integerObjectOf: count].
count < self numSlotsMask ifTrue:
[| smallObj |
smallObj := self allocateSlots: count format: self arrayFormat classIndex: ClassArrayCompactIndex.
0 to: count - 1 do:
[:i|
self storePointerUnchecked: i ofObject: smallObj withValue: (self fetchPointer: i ofFreeChunk: freeChunk)].
self freeChunkWithBytes: (self bytesInObject: freeChunk) at: (self startOfObject: freeChunk).
self beRootIfOld: smallObj.
self checkFreeSpace.
^smallObj].
bytes := self largeObjectBytesForSlots: count.
start := self startOfObject: freeChunk.
self freeChunkWithBytes: limit - start - bytes at: start + bytes.
totalFreeOldSpace := totalFreeOldSpace - bytes.
self setOverflowNumSlotsOf: freeChunk to: count.
self set: freeChunk classIndexTo: ClassArrayCompactIndex formatTo: self arrayFormat.
self possibleRootStoreInto: freeChunk.
self checkFreeSpace.
self runLeakCheckerForFullGC: false.
^freeChunk
!
Item was changed:
----- Method: SpurMemoryManager>>allObjects (in category 'primitive support') -----
allObjects
"Attempt to answer an array of all objects, excluding those that may
be garbage collected as a side effect of allocating the result array.
If no memory is available answer the number of objects as a SmallInteger.
Since objects are at least 16 bytes big, and the largest SmallInteger covers
1/4 of the address space, the count can never overflow."
| freeChunk ptr start limit count bytes |
MarkObjectsForEnumerationPrimitives ifTrue:
[self markObjects: true]. "may not want to revive objects unnecessarily; but marking is sloooow."
freeChunk := self allocateLargestFreeChunk.
ptr := start := freeChunk + self baseHeaderSize.
limit := self addressAfter: freeChunk.
count := 0.
self allHeapEntitiesDo:
[:obj| "continue enumerating even if no room so as to unmark all objects."
(MarkObjectsForEnumerationPrimitives
ifTrue: [self isMarked: obj]
ifFalse: [true]) ifTrue:
[(self isNormalObject: obj)
ifTrue:
[MarkObjectsForEnumerationPrimitives ifTrue:
[self setIsMarkedOf: obj to: false].
count := count + 1.
ptr < limit ifTrue:
[self longAt: ptr put: obj.
+ ptr := ptr + self bytesPerOop]]
- ptr := ptr + self bytesPerSlot]]
ifFalse:
[MarkObjectsForEnumerationPrimitives ifTrue:
[(self isSegmentBridge: obj) ifFalse:
[self setIsMarkedOf: obj to: false]]]]].
self assert: (self isEmptyObjStack: markStack).
MarkObjectsForEnumerationPrimitives
ifTrue:
[self assert: self allObjectsUnmarked.
self emptyObjStack: weaklingStack]
ifFalse:
[self assert: (self isEmptyObjStack: weaklingStack)].
self assert: count >= self numSlotsMask.
+ (count > (ptr - start / self bytesPerOop) "not enough room"
- (count > (ptr - start / self bytesPerSlot) "not enough room"
or: [limit ~= ptr and: [limit - ptr <= self allocationUnit]]) ifTrue: "can't split a single word"
[self freeChunkWithBytes: (self bytesInObject: freeChunk) at: (self startOfObject: freeChunk).
self checkFreeSpace.
^self integerObjectOf: count].
bytes := self largeObjectBytesForSlots: count.
start := self startOfObject: freeChunk.
self freeChunkWithBytes: limit - start - bytes at: start + bytes.
totalFreeOldSpace := totalFreeOldSpace - bytes.
self setOverflowNumSlotsOf: freeChunk to: count.
self set: freeChunk classIndexTo: ClassArrayCompactIndex formatTo: self arrayFormat.
self possibleRootStoreInto: freeChunk.
self checkFreeSpace.
self runLeakCheckerForFullGC: false.
^freeChunk
!
Item was changed:
----- Method: SpurMemoryManager>>allUnscannedEphemeronsAreActive (in category 'weakness and ephemerality') -----
allUnscannedEphemeronsAreActive
+ unscannedEphemerons start to: unscannedEphemerons top - self bytesPerOop do:
- unscannedEphemerons start to: unscannedEphemerons top - self bytesPerSlot do:
[:p| | key |
key := self keyOfEphemeron: (self longAt: p).
((self isImmediate: key) or: [self isMarked: key]) ifTrue:
[^false]].
^true!
Item was changed:
----- Method: SpurMemoryManager>>allocateBytes:classIndex: (in category 'allocation') -----
allocateBytes: numBytes classIndex: classIndex
"Allocate an object of numBytes. Answer nil if no available memory.
classIndex must be that of a byte class (e.g. ByteString).
The object is *NOT FILLED*."
<var: #numBytes type: #usqInt>
self assert: (coInterpreter addressCouldBeClassObj: (self classAtIndex: classIndex)).
self assert: (self instSpecOfClass: (self classAtIndex: classIndex)) = self firstByteFormat.
^self
+ allocateSlots: (numBytes + self bytesPerOop - 1 // self bytesPerOop)
- allocateSlots: (numBytes + self bytesPerSlot - 1 // self bytesPerSlot)
format: (self byteFormatForNumBytes: numBytes)
classIndex: classIndex!
Item was changed:
----- Method: SpurMemoryManager>>ambiguousClass:allInstancesInto:limit:resultsInto: (in category 'primitive support') -----
ambiguousClass: aClass allInstancesInto: start limit: limit resultsInto: binaryBlock
"Dea with ambiguity and normalize indices."
<inline: true>
| expectedIndex count ptr |
count := 0.
ptr := start.
expectedIndex := self rawHashBitsOf: aClass.
self allHeapEntitiesDo:
[:obj| | actualIndex | "continue enumerating even if no room so as to unmark all objects and/or normalize class indices."
(MarkObjectsForEnumerationPrimitives
ifTrue: [self isMarked: obj]
ifFalse: [true]) ifTrue:
[(self isNormalObject: obj)
ifTrue:
[MarkObjectsForEnumerationPrimitives ifTrue:
[self setIsMarkedOf: obj to: false].
actualIndex := self classIndexOf: obj.
(self classOrNilAtIndex: actualIndex) = aClass ifTrue:
[actualIndex ~= expectedIndex ifTrue:
[self setClassIndexOf: obj to: expectedIndex].
count := count + 1.
ptr < limit ifTrue:
[self longAt: ptr put: obj.
+ ptr := ptr + self bytesPerOop]]]
- ptr := ptr + self bytesPerSlot]]]
ifFalse:
[MarkObjectsForEnumerationPrimitives ifTrue:
[(self isSegmentBridge: obj) ifFalse:
[self setIsMarkedOf: obj to: false]]]]].
self purgeDuplicateClassTableEntriesFor: aClass.
binaryBlock value: count value: ptr
!
Item was changed:
----- Method: SpurMemoryManager>>averageObjectSizeInBytes (in category 'accessing') -----
averageObjectSizeInBytes
"Answer an approximation of the average object size. This is a bit of an underestimate.
In the 32-bit system average object size is about 11 words per object, including header."
+ ^8 * self bytesPerOop!
- ^8 * self bytesPerSlot!
Item was changed:
----- Method: SpurMemoryManager>>byteSizeOfInstanceOf:withIndexableSlots:errInto: (in category 'indexing primitive support') -----
byteSizeOfInstanceOf: classObj withIndexableSlots: nElements errInto: errorBlock
| instSpec classFormat numSlots |
<var: 'numSlots' type: #usqInt>
classFormat := self formatOfClass: classObj.
instSpec := self instSpecOfClassFormat: classFormat.
instSpec caseOf: {
[self arrayFormat] ->
[numSlots := nElements].
[self indexablePointersFormat] ->
[numSlots := (self fixedFieldsOfClassFormat: classFormat) + nElements].
[self weakArrayFormat] ->
[numSlots := (self fixedFieldsOfClassFormat: classFormat) + nElements].
[self sixtyFourBitIndexableFormat] ->
+ [numSlots := self bytesPerOop = 4 ifTrue: [nElements * 2] ifFalse: [nElements]].
- [numSlots := self bytesPerSlot = 4 ifTrue: [nElements * 2] ifFalse: [nElements]].
[self firstLongFormat] ->
+ [numSlots := self bytesPerOop = 4 ifTrue: [nElements] ifFalse: [nElements + 1 // 2]].
- [numSlots := self bytesPerSlot = 4 ifTrue: [nElements] ifFalse: [nElements + 1 // 2]].
[self firstShortFormat] ->
+ [numSlots := self bytesPerOop = 4 ifTrue: [nElements + 1 // 2] ifFalse: [nElements + 3 // 4]].
- [numSlots := self bytesPerSlot = 4 ifTrue: [nElements + 1 // 2] ifFalse: [nElements + 3 // 4]].
[self firstByteFormat] ->
+ [numSlots := nElements + (self bytesPerOop - 1) // self bytesPerOop].
- [numSlots := nElements + (self bytesPerSlot - 1) // self bytesPerSlot].
[self firstCompiledMethodFormat] -> "Assume nElements is derived from CompiledMethod>>basicSize."
+ [numSlots := nElements + (self bytesPerOop - 1) // self bytesPerOop] }
- [numSlots := nElements + (self bytesPerSlot - 1) // self bytesPerSlot] }
otherwise: [^errorBlock value: PrimErrBadReceiver negated]. "non-indexable"
+ numSlots >= (1 << (self bytesPerOop * 8 - self logbytesPerOop)) ifTrue:
- numSlots >= (1 << (self bytesPerSlot * 8 - self logBytesPerSlot)) ifTrue:
[^errorBlock value: PrimErrLimitExceeded].
^self objectBytesForSlots: numSlots!
Item was removed:
- ----- Method: SpurMemoryManager>>bytesPerSlot (in category 'header format') -----
- bytesPerSlot
- ^self subclassResponsibility!
Item was changed:
----- Method: SpurMemoryManager>>containsOnlyValidBecomeObjects: (in category 'become implementation') -----
containsOnlyValidBecomeObjects: array
"Answer 0 if the array contains only unpinned non-immediates.
Otherwise answer an informative error code.
Can't become: immediates!! Shouldn't become pinned objects."
| fieldOffset effectsFlags oop |
fieldOffset := self lastPointerOf: array.
effectsFlags := 0.
"same size as array2"
[fieldOffset >= self baseHeaderSize] whileTrue:
[oop := self longAt: array + fieldOffset.
(self isOopForwarded: oop) ifTrue:
[oop := self followForwarded: oop.
self longAt: array + fieldOffset put: oop].
(self isImmediate: oop) ifTrue: [^PrimErrInappropriate].
(self isPinned: oop) ifTrue: [^PrimErrObjectIsPinned].
effectsFlags := effectsFlags bitOr: (self becomeEffectFlagsFor: oop).
+ fieldOffset := fieldOffset - self bytesPerOop].
- fieldOffset := fieldOffset - BytesPerOop].
"only set flags after checking all args."
becomeEffectsFlags := effectsFlags.
^0!
Item was changed:
----- Method: SpurMemoryManager>>containsOnlyValidBecomeObjects:and: (in category 'become implementation') -----
containsOnlyValidBecomeObjects: array1 and: array2
"Answer 0 if neither array contains only unpinned non-immediates.
Otherwise answer an informative error code.
Can't become: immediates!! Shouldn't become pinned objects."
| fieldOffset effectsFlags oop |
fieldOffset := self lastPointerOf: array1.
effectsFlags := 0.
"same size as array2"
[fieldOffset >= self baseHeaderSize] whileTrue:
[oop := self longAt: array1 + fieldOffset.
(self isOopForwarded: oop) ifTrue:
[oop := self followForwarded: oop.
self longAt: array1 + fieldOffset put: oop].
(self isImmediate: oop) ifTrue: [^PrimErrInappropriate].
(self isPinned: oop) ifTrue: [^PrimErrObjectIsPinned].
effectsFlags := effectsFlags bitOr: (self becomeEffectFlagsFor: oop).
oop := self longAt: array2 + fieldOffset.
(self isOopForwarded: oop) ifTrue:
[oop := self followForwarded: oop.
self longAt: array2 + fieldOffset put: oop].
(self isImmediate: oop) ifTrue: [^PrimErrInappropriate].
(self isPinned: oop) ifTrue: [^PrimErrObjectIsPinned].
effectsFlags := effectsFlags bitOr: (self becomeEffectFlagsFor: oop).
+ fieldOffset := fieldOffset - self bytesPerOop].
- fieldOffset := fieldOffset - BytesPerOop].
"only set flags after checking all args."
becomeEffectsFlags := effectsFlags.
^0!
Item was changed:
----- Method: SpurMemoryManager>>eeInstantiateSmallClass:numSlots: (in category 'instantiation') -----
eeInstantiateSmallClass: classObj numSlots: numSlots
"Instantiate an instance of a class, with only a few slots. ee stands for execution
engine and implies that this allocation will *NOT* cause a GC. N.B. the instantiated
object IS NOT FILLED and must be completed before returning it to Smalltalk. Since
this call is used in routines that do just that we are safe. Break this rule and die in GC.
+ Result is guaranteed to be young. We assume this is only used on classes that are
+ already in the class table."
- Result is guaranteed to be young."
- | classIndex |
<inline: true>
+ self assert: (self rawHashBitsOf: classObj) ~= 0.
- classIndex := self ensureBehaviorHash: classObj.
^self
+ eeInstantiateSmallClassIndex: (self rawHashBitsOf: classObj)
- eeInstantiateSmallClassIndex: classIndex
format: (self instSpecOfClass: classObj)
numSlots: numSlots!
Item was changed:
----- Method: SpurMemoryManager>>findString: (in category 'debug support') -----
findString: aCString
"Print the oops of all string-like things that have the same characters as aCString"
<api>
<var: #aCString type: #'char *'>
| cssz |
cssz := self strlen: aCString.
self allObjectsDo:
[:obj|
((self isBytesNonImm: obj)
and: [(self lengthOf: obj) = cssz
+ and: [(self str: aCString n: (self pointerForOop: obj + self baseHeaderSize) cmp: cssz) = 0]]) ifTrue:
- and: [(self str: aCString n: (self pointerForOop: obj + BaseHeaderSize) cmp: cssz) = 0]]) ifTrue:
[coInterpreter printHex: obj; space; printOopShort: obj; cr]]!
Item was changed:
----- Method: SpurMemoryManager>>findStringBeginningWith: (in category 'debug support') -----
findStringBeginningWith: aCString
"Print the oops of all string-like things that start with the same characters as aCString"
<api>
<var: #aCString type: #'char *'>
| cssz |
cssz := self strlen: aCString.
self allObjectsDo:
[:obj|
((self isBytesNonImm: obj)
and: [(self lengthOf: obj) >= cssz
+ and: [(self str: aCString n: (self pointerForOop: obj + self baseHeaderSize) cmp: cssz) = 0]]) ifTrue:
- and: [(self str: aCString n: (self pointerForOop: obj + BaseHeaderSize) cmp: cssz) = 0]]) ifTrue:
[coInterpreter printHex: obj; space; printNum: (self lengthOf: obj); space; printOopShort: obj; cr]]!
Item was changed:
----- Method: SpurMemoryManager>>fixedFieldsOf:format:length: (in category 'object format') -----
fixedFieldsOf: objOop format: fmt length: wordLength
| class |
<inline: true>
- <asmLabel: false>
"N.B. written to fall through to fetchClassOfNonImm: et al for forwarders
so as to trigger an assert fail."
(fmt >= self sixtyFourBitIndexableFormat or: [fmt = self arrayFormat]) ifTrue:
[^0]. "indexable fields only"
fmt < self arrayFormat ifTrue:
[^wordLength]. "fixed fields only (zero or more)"
class := self fetchClassOfNonImm: objOop.
^self fixedFieldsOfClassFormat: (self formatOfClass: class)!
Item was changed:
----- Method: SpurMemoryManager>>initializeObjectMemory: (in category 'initialization') -----
initializeObjectMemory: bytesToShift
"Initialize object memory variables at startup time. Assume endOfMemory at al are
initialised by the image-reading code via setHeapBase:memoryLimit:endOfMemory:.
endOfMemory is assumed to point to the end of the last object in the image.
Assume: image reader also initializes the following variables:
specialObjectsOop
lastHash"
<inline: false>
| freeListObj |
"Catch mis-initializations leading to bad translations to C"
+ self assert: self baseHeaderSize = self baseHeaderSize.
+ self assert: (self maxSlotsForAlloc * self wordSize) asInteger > 0.
- self assert: BaseHeaderSize = self baseHeaderSize.
- self assert: (self maxSlotsForAlloc * BytesPerWord) asInteger > 0.
self bootstrapping ifFalse:
[self
initSegmentBridgeWithBytes: self bridgeSize
at: endOfMemory - self bridgeSize].
segmentManager adjustSegmentSwizzlesBy: bytesToShift.
"image may be at a different address; adjust oops for new location"
self adjustAllOopsBy: bytesToShift.
specialObjectsOop := segmentManager swizzleObj: specialObjectsOop.
"heavily used special objects"
nilObj := self splObj: NilObject.
falseObj := self splObj: FalseObject.
trueObj := self splObj: TrueObject.
"In Cog we insist that nil, true & false are next to each other (Cogit generates tighter
conditional branch code as a result). In addition, Spur places the free lists and
class table root page immediately following them."
self assert: nilObj = oldSpaceStart.
self assert: falseObj = (self objectAfter: nilObj).
self assert: trueObj = (self objectAfter: falseObj).
freeListObj := self objectAfter: trueObj.
self setHiddenRootsObj: (self objectAfter: freeListObj).
markStack := self swizzleObjStackAt: MarkStackRootIndex.
weaklingStack := self swizzleObjStackAt: WeaklingStackRootIndex.
ephemeronQueue := self swizzleObjStackAt: EphemeronQueueRootIndex.
self assert: self validObjStacks.
self assert: (self isEmptyObjStack: markStack).
self assert: (self isEmptyObjStack: weaklingStack).
self initializeFreeSpacePostLoad: freeListObj.
segmentManager collapseSegmentsPostSwizzle.
self computeFreeSpacePostSwizzle.
self initializeOldSpaceFirstFree: freeOldSpaceStart. "initializes endOfMemory, freeStart, free space"
"self bootstrapping ifFalse:
["self initializeNewSpaceVariables.
scavenger initializeRememberedSet"]".
segmentManager checkSegments.
numCompactionPasses := CompactionPassesForGC.
"These defaults should depend on machine size; e.g. too small on a powerful laptop, too big on a Pi."
growHeadroom := 16*1024*1024. "headroom when growing"
shrinkThreshold := 32*1024*1024. "free space before shrinking"
self setHeapSizeAtPreviousGC.
heapGrowthToSizeGCRatio := 0.333333. "By default GC after scavenge if heap has grown by a third since the last GC"!
Item was changed:
----- Method: SpurMemoryManager>>isClassOfNonImm:equalTo:compactClassIndex: (in category 'object access') -----
isClassOfNonImm: oop equalTo: classOop compactClassIndex: knownClassIndex
"Answer if the given (non-immediate) object is an instance of the given class
that may have a knownClassIndex (if knownClassIndex is non-zero). This method
is misnamed given SPur's architecture (where all objects have ``compact'' class indices)
but is so-named for compatibility with ObjectMemory.
N.B. Inlining and/or compiler optimization should result in classOop not being
accessed if knownClassIndex is non-zero."
| ccIndex |
<inline: true>
- <asmLabel: false>
self assert: (self isImmediate: oop) not.
ccIndex := self classIndexOf: oop.
knownClassIndex ~= 0 ifTrue:
[^knownClassIndex = ccIndex].
^classOop = (self classAtIndex: ccIndex)!
Item was changed:
----- Method: SpurMemoryManager>>lastPointerOf: (in category 'object enumeration') -----
lastPointerOf: objOop
"Answer the byte offset of the last pointer field of the given object.
Works with CompiledMethods, as well as ordinary objects."
<api>
<inline: true>
- <asmLabel: false>
| fmt contextSize header |
fmt := self formatOf: objOop.
self assert: fmt ~= self forwardedFormat.
fmt <= self lastPointerFormat ifTrue:
[(fmt = self indexablePointersFormat
and: [self isContextNonImm: objOop]) ifTrue:
["contexts end at the stack pointer"
contextSize := coInterpreter fetchStackPointerOf: objOop.
+ ^CtxtTempFrameStart - 1 + contextSize * self bytesPerOop + self baseHeaderSize].
+ ^(self numSlotsOf: objOop) - 1 * self bytesPerOop + self baseHeaderSize "all pointers"].
- ^CtxtTempFrameStart - 1 + contextSize * BytesPerOop + self baseHeaderSize].
- ^(self numSlotsOf: objOop) - 1 * BytesPerOop + self baseHeaderSize "all pointers"].
fmt < self firstCompiledMethodFormat ifTrue: [^0]. "no pointers"
"CompiledMethod: contains both pointers and bytes"
header := self methodHeaderOf: objOop.
^self lastPointerOfMethodHeader: header!
Item was changed:
----- Method: SpurMemoryManager>>lastPointerOfMethodHeader: (in category 'object enumeration') -----
lastPointerOfMethodHeader: methodHeader
"Answer the byte offset of the last pointer field of a
CompiledMethod with the given header."
<inline: true>
- <asmLabel: false>
^(self literalCountOfMethodHeader: methodHeader)
+ + LiteralStart - 1 * self bytesPerOop + self baseHeaderSize!
- + LiteralStart - 1 * BytesPerOop + self baseHeaderSize!
Item was changed:
----- Method: SpurMemoryManager>>lastPointerOfWhileSwizzling: (in category 'snapshot') -----
lastPointerOfWhileSwizzling: objOop
"Answer the byte offset of the last pointer field of the given object.
Works with CompiledMethods, as well as ordinary objects.
Does not examine the stack pointer of contexts to be sure to swizzle
the nils that fill contexts on snapshot.
It is invariant that on image load no object contains a forwarding pointer,
and the image contains no forwarders (see class comment)."
<api>
<inline: true>
- <asmLabel: false>
| fmt header |
fmt := self formatOf: objOop.
self assert: fmt ~= self forwardedFormat.
fmt <= self lastPointerFormat ifTrue:
[^(self numSlotsOf: objOop) - 1 * self bytesPerOop + self baseHeaderSize "all pointers"].
fmt < self firstCompiledMethodFormat ifTrue: [^0]. "no pointers"
"CompiledMethod: contains both pointers and bytes"
header := self methodHeaderOf: objOop.
^self lastPointerOfMethodHeader: header!
Item was changed:
----- Method: SpurMemoryManager>>lengthOf: (in category 'object access') -----
lengthOf: objOop
"Answer the number of indexable units in the given object.
For a CompiledMethod, the size of the method header (in bytes) should
be subtracted from the result."
<api>
<inline: true>
- <asmLabel: false>
^self lengthOf: objOop format: (self formatOf: objOop)!
Item was changed:
----- Method: SpurMemoryManager>>lengthOf:format: (in category 'object access') -----
lengthOf: objOop format: fmt
"Answer the number of indexable units in the given object.
For a CompiledMethod, the size of the method header (in bytes)
should be subtracted from the result of this method."
| numSlots |
<inline: true>
- <asmLabel: false>
numSlots := self numSlotsOfAny: objOop. "don't let forwarders freak us out..."
fmt <= self sixtyFourBitIndexableFormat ifTrue:
[^numSlots].
fmt >= self firstByteFormat ifTrue: "bytes, including CompiledMethod"
[^numSlots << self shiftForWord - (fmt bitAnd: 7)].
fmt >= self firstShortFormat ifTrue:
[^numSlots << (self shiftForWord - 1) - (fmt bitAnd: 3)].
"fmt >= self firstLongFormat"
^numSlots << (self shiftForWord - 2) - (fmt bitAnd: 1)!
Item was changed:
----- Method: SpurMemoryManager>>loadImageSegmentFrom:outPointers: (in category 'image segment in/out') -----
loadImageSegmentFrom: segmentWordArray outPointers: outPointerArray
"This primitive is called from Squeak as...
<imageSegment> loadSegmentFrom: aWordArray outPointers: anArray."
"This primitive will load a binary image segment created by primitiveStoreImageSegment.
It expects the outPointer array to be of the proper size, and the wordArray to be well formed.
It will return as its value the original array of roots, and the erstwhile segmentWordArray will
have been truncated to a size of one word, i.e. retaining the version stamp. If this primitive
should fail, the segmentWordArray will, sadly, have been reduced to an unrecognizable and
unusable jumble. But what more could you have done with it anyway?"
<inline: false>
| segmentLimit segmentStart segVersion errorCode |
segmentLimit := self numSlotsOf: segmentWordArray.
(self objectBytesForSlots: segmentLimit) < (self allocationUnit "version info" + self baseHeaderSize "one object header") ifTrue:
[^PrimErrBadArgument].
"First thing is to verify format. If Spur is ever ported to big-endian machines then the segment
may have to be byte/word swapped, but so far it only runs on little-endian machines, so for now
just fail if endinanness is wrong."
segVersion := self longAt: segmentWordArray + self baseHeaderSize.
(coInterpreter readableFormat: (segVersion bitAnd: 16rFFFF "low 2 bytes")) ifFalse:
[self reverseBytesFrom: segmentWordArray + self baseHeaderSize
to: (self addressAfter: segmentWordArray).
segVersion := self longAt: segmentWordArray + self baseHeaderSize.
(coInterpreter readableFormat: (segVersion bitAnd: 16rFFFF "low 2 bytes")) ifFalse:
[self reverseBytesFrom: segmentWordArray + self baseHeaderSize
to: (self addressAfter: segmentWordArray).
^PrimErrBadArgument]].
segmentStart := segmentWordArray + self baseHeaderSize + self allocationUnit.
segmentLimit := segmentLimit * self bytesPerOop + segmentWordArray + self baseHeaderSize.
"Notionally reverse the Byte type objects if the data is from opposite endian machine.
Test top byte. $d on the Mac or $s on the PC. Rest of word is equal. If Spur is ever
ported to big-endian machines then the segment may have to be byte/word swapped,
but so far it only runs on little-endian machines, so for now just fail if endinanness is wrong."
self flag: #endianness.
(segVersion >> 16) ~= (self imageSegmentVersion >> 16) ifTrue:
"Reverse the byte-type objects once"
[true
ifTrue: [^PrimErrBadArgument]
ifFalse:
[self byteSwapByteObjectsFrom: (self objectStartingAt: segmentStart)
to: segmentLimit
flipFloatsIf: false]].
"scan through mapping oops and validating class references. Defer entering any
class objects into the class table and/or pinning objects until a second pass."
errorCode := self mapOopsAndValidateClassRefsFrom: segmentStart to: segmentLimit outPointers: outPointerArray.
errorCode ~= 0 ifTrue:
[^errorCode].
"Scan for classes contained in the segment, entering them into the class table.
Classes are at the front, after the root array and have the remembered bit set."
errorCode := self enterClassesIntoClassTableFrom: segmentStart to: segmentLimit.
errorCode ~= 0 ifTrue:
[^errorCode].
"Make a final pass, assigning class indices and/or pinning pinned objects"
self assignClassIndicesAndPinFrom: segmentStart to: segmentLimit outPointers: outPointerArray.
"Finally evaporate the container, leaving the newly loaded objects in place."
(self hasOverflowHeader: segmentWordArray)
+ ifTrue: [self setOverflowNumSlotsOf: segmentWordArray to: self allocationUnit / self bytesPerOop]
+ ifFalse: [self setRawNumSlotsOf: segmentWordArray to: self allocationUnit / self bytesPerOop].
- ifTrue: [self setOverflowNumSlotsOf: segmentWordArray to: self allocationUnit / self bytesPerSlot]
- ifFalse: [self setRawNumSlotsOf: segmentWordArray to: self allocationUnit / self bytesPerSlot].
self leakCheckImageSegments ifTrue:
[self runLeakCheckerForFullGC: true].
^self objectStartingAt: segmentStart!
Item was changed:
----- Method: SpurMemoryManager>>minSlotsForShortening (in category 'allocation') -----
minSlotsForShortening
"Answer the minimum number of additional slots to allocate in an object to always be able to shorten it.
This is enough slots to allocate a minimum-sized object."
+ ^self allocationUnit * 2 / self bytesPerOop!
- ^self allocationUnit * 2 / self bytesPerSlot!
Item was changed:
----- Method: SpurMemoryManager>>numBytesOf: (in category 'object access') -----
numBytesOf: objOop
"Answer the number of indexable bytes in the given non-immediate object.
Does not adjust the size of contexts by stackPointer."
<api>
| fmt numBytes |
<inline: true>
- <asmLabel: false>
fmt := self formatOf: objOop.
numBytes := self numSlotsOf: objOop.
numBytes := numBytes << self shiftForWord.
fmt <= self sixtyFourBitIndexableFormat ifTrue:
[^numBytes].
fmt >= self firstByteFormat ifTrue: "bytes, including CompiledMethod"
[^numBytes - (fmt bitAnd: 7)].
fmt >= self firstShortFormat ifTrue:
[^numBytes - ((fmt bitAnd: 3) << 1)].
"fmt >= self firstLongFormat"
^numBytes - ((fmt bitAnd: 1) << 2)!
Item was changed:
----- Method: SpurMemoryManager>>numFixedSlotsOf: (in category 'object format') -----
numFixedSlotsOf: objOop
<inline: true>
- <asmLabel: false>
^self fixedFieldsOfClassFormat: (self formatOfClass: (self fetchClassOfNonImm: objOop))!
Item was changed:
----- Method: SpurMemoryManager>>numPointerSlotsOf: (in category 'object access') -----
numPointerSlotsOf: objOop
"Answer the number of pointer fields in the given object.
Works with CompiledMethods, as well as ordinary objects."
<api>
<inline: true>
- <asmLabel: false>
| fmt contextSize numLiterals header |
fmt := self formatOf: objOop.
fmt <= self lastPointerFormat ifTrue:
[(fmt = self indexablePointersFormat
and: [self isContextNonImm: objOop]) ifTrue:
["contexts end at the stack pointer"
contextSize := coInterpreter fetchStackPointerOf: objOop.
^CtxtTempFrameStart + contextSize].
^self numSlotsOf: objOop "all pointers"].
fmt = self forwardedFormat ifTrue: [^1].
fmt < self firstCompiledMethodFormat ifTrue: [^0]. "no pointers"
"CompiledMethod: contains both pointers and bytes"
header := self methodHeaderOf: objOop.
numLiterals := self literalCountOfMethodHeader: header.
^numLiterals + LiteralStart!
Item was changed:
----- Method: SpurMemoryManager>>numStrongSlotsOf:format:ephemeronInactiveIf: (in category 'object access') -----
numStrongSlotsOf: objOop format: fmt ephemeronInactiveIf: criterion
"Answer the number of strong pointer fields in the given object.
Works with CompiledMethods, as well as ordinary objects."
<var: 'criterion' declareC: 'int (*criterion)(sqInt key)'>
<inline: true>
- <asmLabel: false>
| numSlots contextSize numLiterals header |
fmt <= self lastPointerFormat ifTrue:
[numSlots := self numSlotsOf: objOop.
fmt <= self arrayFormat ifTrue:
[^numSlots].
fmt = self indexablePointersFormat ifTrue:
[(self isContextNonImm: objOop) ifTrue:
[coInterpreter setTraceFlagOnContextsFramesPageIfNeeded: objOop.
"contexts end at the stack pointer"
contextSize := coInterpreter fetchStackPointerOf: objOop.
^CtxtTempFrameStart + contextSize].
^numSlots].
fmt = self weakArrayFormat ifTrue:
[^self fixedFieldsOfClass: (self fetchClassOfNonImm: objOop)].
self assert: fmt = self ephemeronFormat.
^(self perform: criterion with: (self keyOfEphemeron: objOop))
ifTrue: [numSlots]
ifFalse: [0]].
fmt = self forwardedFormat ifTrue: [^1].
fmt < self firstCompiledMethodFormat ifTrue: [^0]. "no pointers"
"CompiledMethod: contains both pointers and bytes"
header := self methodHeaderOf: objOop.
numLiterals := self literalCountOfMethodHeader: header.
^numLiterals + LiteralStart!
Item was changed:
----- Method: SpurMemoryManager>>numStrongSlotsOfInephemeral: (in category 'object access') -----
numStrongSlotsOfInephemeral: objOop
"Answer the number of strong pointer fields in the given object,
which is .expected not to be an active ephemeron.
Works with CompiledMethods, as well as ordinary objects."
<inline: true>
- <asmLabel: false>
| fmt numSlots contextSize numLiterals header |
fmt := self formatOf: objOop.
self assert: (fmt ~= self ephemeronFormat or: [self isMarked: (self keyOfEphemeron: objOop)]).
fmt <= self lastPointerFormat ifTrue:
[numSlots := self numSlotsOf: objOop.
fmt <= self arrayFormat ifTrue:
[^numSlots].
fmt = self indexablePointersFormat ifTrue:
[(self isContextNonImm: objOop) ifTrue:
[coInterpreter setTraceFlagOnContextsFramesPageIfNeeded: objOop.
"contexts end at the stack pointer"
contextSize := coInterpreter fetchStackPointerOf: objOop.
^CtxtTempFrameStart + contextSize].
^numSlots].
fmt = self weakArrayFormat ifTrue:
[^self fixedFieldsOfClass: (self fetchClassOfNonImm: objOop)]].
fmt = self forwardedFormat ifTrue: [^1].
fmt < self firstCompiledMethodFormat ifTrue: [^0]. "no pointers"
"CompiledMethod: contains both pointers and bytes"
header := self methodHeaderOf: objOop.
numLiterals := self literalCountOfMethodHeader: header.
^numLiterals + LiteralStart!
Item was changed:
----- Method: SpurMemoryManager>>numStrongSlotsOfWeakling: (in category 'object access') -----
numStrongSlotsOfWeakling: objOop
"Answer the number of strong pointer fields in the given weakling."
<api>
<inline: true>
- <asmLabel: false>
self assert: (self formatOf: objOop) = self weakArrayFormat.
^self fixedFieldsOfClass: (self fetchClassOfNonImm: objOop)!
Item was changed:
----- Method: SpurMemoryManager>>objectsReachableFromRoots: (in category 'image segment in/out') -----
objectsReachableFromRoots: arrayOfRoots
"Answer an Array of all the objects only reachable from the argument, an Array of root objects,
starting with arrayOfRoots. If there is no space, answer a SmallInteger whose value is the
number of slots required. This is used to collect the objects to include in an image segment
on Spur, separate from creating the segment, hence simplifying the implementation.
Thanks to Igor Stasenko for this idea."
| freeChunk ptr start limit count oop objOop |
self assert: (self isArray: arrayOfRoots).
"Mark all objects except those only reachable from the arrayOfRoots by marking
each object in arrayOfRoots and then marking all reachable objects (from the
system roots). This leaves unmarked only objects reachable from the arrayOfRoots.
N.B. A side-effect of the marking is that all forwarders in arrayOfRoots will be followed."
self assert: self allObjectsUnmarked.
self markObjectsIn: arrayOfRoots.
self markObjects: false.
"After the mark phase all unreachable weak slots will have been nilled
and all active ephemerons fired."
self assert: (self isEmptyObjStack: markStack).
self assert: (self isEmptyObjStack: weaklingStack).
self assert: self noUnscannedEphemerons.
"Use the largest free chunk to answer the result."
freeChunk := self allocateLargestFreeChunk.
ptr := start := freeChunk + self baseHeaderSize.
limit := self addressAfter: freeChunk.
count := 0.
"First put the arrayOfRoots; order is important."
count := count + 1.
ptr < limit ifTrue:
[self longAt: ptr put: arrayOfRoots.
+ ptr := ptr + self bytesPerOop].
- ptr := ptr + self bytesPerSlot].
0 to: (self numSlotsOf: arrayOfRoots) - 1 do:
[:i|
oop := self fetchPointer: i ofObject: arrayOfRoots.
(self isNonImmediate: oop) ifTrue:
[self push: oop onObjStack: markStack]].
"Now collect the unmarked objects reachable from the roots."
[self isEmptyObjStack: markStack] whileFalse:
[objOop := self popObjStack: markStack.
count := count + 1.
ptr < limit ifTrue:
[self longAt: ptr put: objOop.
+ ptr := ptr + self bytesPerOop].
- ptr := ptr + self bytesPerSlot].
oop := self fetchClassOfNonImm: objOop.
(self isMarked: oop) ifFalse:
[self setIsMarkedOf: objOop to: true.
self push: oop onObjStack: markStack].
((self isContextNonImm: objOop)
and: [coInterpreter isStillMarriedContext: objOop]) "widow now, before the loop"
ifTrue:
[0 to: (coInterpreter numSlotsOfMarriedContext: objOop) - 1 do:
[:i|
oop := coInterpreter fetchPointer: i ofMarriedContext: objOop.
((self isImmediate: oop)
or: [self isMarked: oop]) ifFalse:
[self setIsMarkedOf: objOop to: true.
self push: oop onObjStack: markStack]]]
ifFalse:
[0 to: (self numPointerSlotsOf: objOop) - 1 do:
[:i|
oop := self fetchPointer: i ofObject: objOop.
((self isImmediate: oop)
or: [self isMarked: oop]) ifFalse:
[self setIsMarkedOf: objOop to: true.
self push: oop onObjStack: markStack]]]].
self unmarkAllObjects.
totalFreeOldSpace := totalFreeOldSpace - (self bytesInObject: freeChunk).
"Now try and allocate the result"
+ (count > (ptr - start / self bytesPerOop) "not enough room"
- (count > (ptr - start / self bytesPerSlot) "not enough room"
or: [limit ~= ptr and: [limit - ptr <= self allocationUnit]]) ifTrue: "can't split a single word"
[self freeChunkWithBytes: (self bytesInObject: freeChunk) at: (self startOfObject: freeChunk).
self checkFreeSpace.
^self integerObjectOf: count].
"There's room; set the format, & classIndex and shorten."
self setFormatOf: freeChunk to: self arrayFormat.
self setClassIndexOf: freeChunk to: ClassArrayCompactIndex.
self shorten: freeChunk toIndexableSize: count.
self possibleRootStoreInto: freeChunk.
self checkFreeSpace.
self runLeakCheckerForFullGC: false.
^freeChunk!
Item was changed:
----- Method: SpurMemoryManager>>printMemoryFrom:to: (in category 'debug printing') -----
printMemoryFrom: start to: end
<doNotGenerate>
| address |
address := start bitAnd: (self wordSize - 1) bitInvert.
[address < end] whileTrue:
[coInterpreter printHex: address; printChar: $:; space; printHex: (self longAt: address); cr.
+ address := address + self wordSize]!
- address := address + BytesPerWord]!
Item was changed:
----- Method: SpurMemoryManager>>reverseBytesFrom:to: (in category 'snapshot') -----
reverseBytesFrom: startAddr to: stopAddr
"Byte-swap the given range of memory (not inclusive of stopAddr!!)."
| addr |
addr := startAddr.
[self oop: addr isLessThan: stopAddr] whileTrue:
[self longAt: addr put: (self byteSwapped: (self longAt: addr)).
+ addr := addr + self wordSize]!
- addr := addr + BytesPerWord]!
Item was changed:
----- Method: SpurMemoryManager>>storeImageSegmentInto:outPointers:roots: (in category 'image segment in/out') -----
storeImageSegmentInto: segmentWordArray outPointers: outPointerArray roots: arrayOfRoots
"This primitive is called from Squeak as...
<imageSegment> storeSegmentFor: arrayOfRoots into: aWordArray outPointers: anArray.
This primitive will store a binary image segment (in the same format as objercts in the heap) of the
set of objects in arrayOfObjects. All pointers from within the set to objects outside the set will be
copied into the array of outPointers. In their place in the image segment will be an oop equal to the
offset in the outPointer array (the first would be 4). but with the high bit set.
Since Spur has a class table the load primitive must insert classes that have instances in the class
table. This primitive marks such classes using the isRemembered bit, which isn't meaningful as a
remembered bit in the segment.
The primitive expects the segmentWordArray and outPointerArray to be more than adequately long.
In this case it returns normally, and truncates the two arrays to exactly the right size.
The primitive can fail for the following reasons with the specified failure codes:
PrimErrWritePastObject: the segmentWordArray is too small
PrimErrBadIndex: the outPointerArray is too small
PrimErrNoMemory: additional allocations failed
PrimErrLimitExceeded: there is no room in the hash field to store object oops."
<inline: false>
| arrayOfObjects savedInHashes savedOutHashes fillValue segStart segAddr endSeg outIndex |
self leakCheckImageSegments ifTrue:
[self runLeakCheckerForFullGC: true].
"First compute the transitive closure, collecting the sequence of objects to be stored in the arrayOfObjects array."
arrayOfObjects := self objectsReachableFromRoots: arrayOfRoots.
arrayOfObjects ifNil:
[^PrimErrNoMemory].
self assert: self allObjectsUnmarked. "work to be done when the incremental GC is written"
"The scheme is to copy the objects into segmentWordArray, and then map the oops in sementWordArray.
Therefore the primitive needs to both map efficiently originals to copies in segmentWordArray and
be able to undo any side-effects if the primitive fails because either sementWordArray or outPointerArray
is too small. The mapping is done by having the originals (either the objects in arrayOfObjects or the
objects in outPointerArray) refer to their mapped locations through their identityHash, and saving their
identityHashes in two ByteArrays, one that mirrors arrayOfObjects, and one that mirrors outPointerArray.
Since arrayOfObjects and its saved hashes, and outPointerArray and its saved hashes, can be enumerated
side-by-side, the hashes can be restored to the originals. So the hash of an object in arrayOfObjects
is set to its offset in segmentWordArray / self allocationUnit, and the hash of an object in outPointerArray
is set to its index in outPointerArray plus the top hash bit. Oops in segmentWordArray are therefore
mapped by accessing the original oop's identityHash, testing the bottom bit to distinguish between internal
and external oops. The saved hash arrays are initialized with an out-of-range hash value so that the first
unused entry can be identified."
savedInHashes := self allocateSlots: (self numSlotsForBytes: (self numSlotsOf: arrayOfObjects) * 4)
format: self firstLongFormat
classIndex: self thirtyTwoBitLongsClassIndexPun.
savedOutHashes := self allocateSlots: (self numSlotsForBytes: (self numSlotsOf: outPointerArray) * 4)
format: self firstLongFormat
classIndex: self thirtyTwoBitLongsClassIndexPun.
(savedInHashes isNil or: [savedOutHashes isNil]) ifTrue:
[self freeObject: arrayOfObjects.
^PrimErrNoMemory].
fillValue := self wordSize = 4 ifTrue: [self maxIdentityHash + 1] ifFalse: [self maxIdentityHash + 1 << 32 + (self maxIdentityHash + 1)].
self fillObj: savedInHashes numSlots: (self numSlotsOf: savedInHashes) with: fillValue.
self fillObj: savedOutHashes numSlots: (self numSlotsOf: savedOutHashes) with: fillValue.
"Both to expand the max size of segment and to reduce the length of the
load-time pass that adds classes to the class table, move classes to the
front of arrayOfObjects, leaving the root array as the first element."
self moveClassesForwardsIn: arrayOfObjects.
segAddr := segmentWordArray + self baseHeaderSize.
endSeg := self addressAfter: segmentWordArray.
"Write a version number for byte order and version check."
segAddr >= endSeg ifTrue: [^PrimErrGenericFailure].
self long32At: segAddr put: self imageSegmentVersion.
self long32At: segAddr + 4 put: self imageSegmentVersion.
segStart := segAddr := segAddr + self allocationUnit.
"Copy all reachable objects to the segment."
0 to: (self numSlotsOf: arrayOfObjects) - 1 do:
[:i| | newSegAddrOrError objOop |
objOop := self fetchPointer: i ofObject: arrayOfObjects.
self deny: ((self isImmediate: objOop) or: [self isForwarded: objOop]).
self storeLong32: i ofObject: savedInHashes withValue: (self rawHashBitsOf: objOop).
newSegAddrOrError := self copyObj: objOop toAddr: segAddr startAt: segStart stopAt: endSeg.
newSegAddrOrError < segStart ifTrue:
[^self return: newSegAddrOrError
restoringObjectsIn: arrayOfObjects savedHashes: savedInHashes
and: outPointerArray savedHashes: savedOutHashes].
segAddr := newSegAddrOrError].
"Check that it can be safely shortened."
(endSeg ~= segAddr
+ and: [endSeg - segAddr < (self baseHeaderSize + self bytesPerOop)]) ifTrue:
- and: [endSeg - segAddr < (self baseHeaderSize + self bytesPerSlot)]) ifTrue:
[^self return: PrimErrWritePastObject
restoringObjectsIn: arrayOfObjects savedHashes: savedInHashes
and: outPointerArray savedHashes: savedOutHashes].
"Now scan, adding out pointers to the outPointersArray; all objects in arrayOfObjects
have their hashes set to point to their copies in segmentWordArray."
(outIndex := self mapOopsFrom: segStart
to: segAddr
outPointers: outPointerArray
outHashes: savedOutHashes) < 0 ifTrue: "no room in outPointers; fail"
[^self return: PrimErrBadIndex
restoringObjectsIn: arrayOfObjects savedHashes: savedInHashes
and: outPointerArray savedHashes: savedOutHashes].
"We're done. SHorten the results, restore hashes and return."
self shorten: segmentWordArray toIndexableSize: segAddr - (segmentWordArray + self baseHeaderSize) / 4.
self shorten: outPointerArray toIndexableSize: outIndex.
^self return: PrimNoErr
restoringObjectsIn: arrayOfObjects savedHashes: savedInHashes
and: outPointerArray savedHashes: savedOutHashes!
Item was changed:
----- Method: SpurMemoryManager>>swizzleFieldsOfObject: (in category 'snapshot') -----
swizzleFieldsOfObject: oop
| fieldAddr fieldOop |
<inline: true>
fieldAddr := oop + (self lastPointerOfWhileSwizzling: oop).
[self oop: fieldAddr isGreaterThanOrEqualTo: oop + self baseHeaderSize] whileTrue:
[fieldOop := self longAt: fieldAddr.
(self isNonImmediate: fieldOop) ifTrue:
[self longAt: fieldAddr put: (segmentManager swizzleObj: fieldOop)].
+ fieldAddr := fieldAddr - self bytesPerOop]!
- fieldAddr := fieldAddr - BytesPerOop]!
Item was changed:
----- Method: SpurMemoryManager>>uniqueIndex:allInstancesInto:limit:resultsInto: (in category 'primitive support') -----
uniqueIndex: classIndex allInstancesInto: start limit: limit resultsInto: binaryBlock
<inline: true>
| count ptr |
count := 0.
ptr := start.
self allHeapEntitiesDo:
[:obj| "continue enumerating even if no room so as to unmark all objects."
(MarkObjectsForEnumerationPrimitives
ifTrue: [self isMarked: obj]
ifFalse: [true]) ifTrue:
[(self isNormalObject: obj)
ifTrue:
[MarkObjectsForEnumerationPrimitives ifTrue:
[self setIsMarkedOf: obj to: false].
(self classIndexOf: obj) = classIndex ifTrue:
[count := count + 1.
ptr < limit ifTrue:
[self longAt: ptr put: obj.
+ ptr := ptr + self bytesPerOop]]]
- ptr := ptr + self bytesPerSlot]]]
ifFalse:
[MarkObjectsForEnumerationPrimitives ifTrue:
[(self isSegmentBridge: obj) ifFalse:
[self setIsMarkedOf: obj to: false]]]]].
binaryBlock value: count value: ptr
!
Item was changed:
----- Method: SpurSegmentManager>>readHeapFromImageFile:dataBytes: (in category 'snapshot') -----
readHeapFromImageFile: f dataBytes: numBytes
"Read numBytes of image data from f into memory at memoryBaseForImageRead.
Answer the number of bytes written. In addition, read each segment, build up the
segment info for swizzling, while eliminating the bridge objects at the end of each
segment that specify the distance to and the size of the subsequent segment."
<var: #f type: #sqImageFile>
<inline: false>
| bytesRead totalBytesRead bridgehead bridge nextSegmentSize oldBase newBase segInfo bridgeSpan |
<var: 'segInfo' type: #'SpurSegmentInfo *'>
self allocateOrExtendSegmentInfos.
"segment sizes include the two-header-word bridge at the end of each segment."
numSegments := totalBytesRead := 0.
oldBase := 0. "N.B. still must be adjusted by oldBaseAddr."
newBase := manager oldSpaceStart.
nextSegmentSize := firstSegmentSize.
bridgehead := firstSegmentSize + manager oldSpaceStart - manager bridgeSize.
[segInfo := self addressOf: (segments at: numSegments).
segInfo
segStart: oldBase; "N.B. still must be adjusted by oldBaseAddr."
segSize: nextSegmentSize;
swizzle: newBase - oldBase. "N.B. still must be adjusted by oldBaseAddr."
bytesRead := self readHeapFrom: f at: newBase dataBytes: nextSegmentSize.
bytesRead > 0 ifTrue:
[totalBytesRead := totalBytesRead + bytesRead].
bytesRead ~= nextSegmentSize ifTrue:
[^totalBytesRead].
numSegments := numSegments + 1.
bridge := bridgehead + manager baseHeaderSize.
bridgeSpan := (manager rawNumSlotsOf: bridgehead) = 0
ifTrue: [0]
+ ifFalse: [manager bytesPerOop * (manager rawOverflowSlotsOf: bridge)].
- ifFalse: [manager bytesPerSlot * (manager rawOverflowSlotsOf: bridge)].
oldBase := oldBase + nextSegmentSize + bridgeSpan.
newBase := newBase + nextSegmentSize - manager bridgeSize.
nextSegmentSize := manager long64At: bridge.
nextSegmentSize ~= 0] whileTrue:
[bridgehead := bridgehead - manager bridgeSize + nextSegmentSize].
"newBase should point just past the last bridge. all others should have been eliminated."
self assert: newBase - manager oldSpaceStart
= (totalBytesRead - (numSegments * manager bridgeSize)).
"set freeOldSpaceStart now for adjustAllOopsBy:"
manager setFreeOldSpaceStart: newBase.
"we're done. nil firstSegmentSize for a subsequent snapshot."
firstSegmentSize := nil.
^totalBytesRead!
Item was changed:
----- Method: StackInterpreter class>>initializeContextIndices (in category 'initialization') -----
initializeContextIndices
"Class MethodContext"
SenderIndex := 0.
InstructionPointerIndex := 1.
StackPointerIndex := 2.
MethodIndex := 3.
ClosureIndex := 4. "N.B. Called receiverMap in old images, closureOrNil in newer images."
ReceiverIndex := 5.
CtxtTempFrameStart := 6.
SmallContextSlots := CtxtTempFrameStart + 16. "16 indexable fields"
"Large contexts have 56 indexable fields. Max with single header word of ObjectMemory [but not SpurMemoryManager ;-)]."
LargeContextSlots := CtxtTempFrameStart + 56.
"Including the header size in these sizes is problematic for multiple memory managers,
+ so we don't use them. Set to #bogus for error checking."
- so we don't use them, except LargeContextSize for asserts. Set small to #bogus for error checking."
SmallContextSize := #bogus.
+ LargeContextSize := #bogus.
- LargeContextSize := LargeContextSlots * BytesPerOop + BaseHeaderSize.
"Class BlockClosure"
ClosureOuterContextIndex := 0.
ClosureStartPCIndex := 1.
ClosureNumArgsIndex := 2.
ClosureFirstCopiedValueIndex := 3.
ClosureCopiedValuesIndex := 3!
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
-1 for 0-based addressing of fetchByte
-1 because it gets incremented BEFORE fetching currentByte"
closureIP := self quickFetchInteger: ClosureStartPCIndex ofObject: blockClosure.
+ instructionPointer := theMethod + closureIP + objectMemory baseHeaderSize - 2.
- instructionPointer := theMethod + closureIP + 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 isWordsOrBytes: arrayOop) ifTrue:
+ [^self cCoerceSimple: (self pointerForOop: arrayOop + objectMemory baseHeaderSize) to: #'void *'].
- [^self cCoerceSimple: (self pointerForOop: arrayOop + BaseHeaderSize) to: #'void *'].
self primitiveFail!
Item was changed:
----- Method: StackInterpreter>>assertClassOf:is: (in category 'utilities') -----
assertClassOf: oop is: classOop
"Succeed if oop is an instance of the given class. Fail if the object is an integer."
<inline: true>
- <asmLabel: false>
self success: (objectMemory isClassOfNonImm: oop equalTo: classOop)!
Item was changed:
----- Method: StackInterpreter>>assertValidExecutionPointe:r:s:imbar:line: (in category 'debug support') -----
assertValidExecutionPointe: lip r: lfp s: lsp imbar: inInterpreter line: ln
<var: #lip type: #usqInt>
<var: #lfp type: #'char *'>
<var: #lsp type: #'char *'>
self assert: inInterpreter l: ln.
self assert: stackPage = (stackPages stackPageFor: lfp) l: ln.
self assert: stackPage = stackPages mostRecentlyUsedPage l: ln.
self assertValidStackLimits: ln.
self assert: lfp < stackPage baseAddress l: ln.
self assert: lsp < lfp l: ln.
self assert: lfp > lsp l: ln.
self assert: lsp >= (stackPage realStackLimit - self stackLimitOffset) l: ln.
+ self assert: (lfp - lsp) / objectMemory bytesPerOop < LargeContextSlots l: ln.
- self assert: (lfp - lsp) < LargeContextSize l: ln.
self assert: (self validInstructionPointer: lip inFrame: lfp) l: ln.
self assert: ((self frameIsBlockActivation: lfp)
or: [(self pushedReceiverOrClosureOfFrame: lfp) = (self frameReceiver: lfp)])
l: ln.
self assert: method = (self frameMethod: lfp) l: ln.
self cppIf: MULTIPLEBYTECODESETS
ifTrue: [self assert: (self methodUsesAlternateBytecodeSet: method) = (bytecodeSetSelector = 256) l: ln].!
Item was changed:
----- Method: StackInterpreter>>bereaveAllMarriedContextsForSnapshotFlushingExternalPrimitivesIf: (in category 'frame access') -----
bereaveAllMarriedContextsForSnapshotFlushingExternalPrimitivesIf: flushExtPrims
"Enumerate all contexts and convert married contexts to widowed contexts so
that the snapshot contains only single contexts. This allows the test for being
married to avoid checking for a context's frame pointer being in bounds. If
flushExtPrims is true, flush references to external primitives in methods."
- <asmLabel: false>
objectMemory allObjectsDo:
[:obj| | fmt |
fmt := objectMemory formatOf: obj.
(fmt = objectMemory indexablePointersFormat
and: [objectMemory isContextNonImm: obj]) ifTrue:
[(self isMarriedOrWidowedContext: obj)
ifTrue: "The stack pages have already been discarded. Any remaining married contexts are actually widows."
[self markContextAsDead: obj]
ifFalse:
[self ensureContextHasBytecodePC: obj].
"Fill slots beyond top of stack with nil"
(self fetchStackPointerOf: obj) + CtxtTempFrameStart
to: (objectMemory numSlotsOf: obj) - 1
do: [:i |
objectMemory
storePointerUnchecked: i
ofObject: obj
withValue: objectMemory nilObject]].
"Clean out external functions from compiled methods"
(flushExtPrims
and: [fmt >= objectMemory firstCompiledMethodFormat]) ifTrue:
["Its primitiveExternalCall"
(self primitiveIndexOf: obj) = PrimitiveExternalCallIndex ifTrue:
[self flushExternalPrimitiveOf: obj]]]!
Item was changed:
----- Method: StackInterpreter>>checkOkayStackPage: (in category 'debug support') -----
checkOkayStackPage: thePage
| theSP theFP ok 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>
theSP := thePage headSP.
theFP := thePage headFP.
ok := true.
"Skip the instruction pointer on top of stack of inactive pages."
thePage = stackPage ifFalse:
+ [theSP := theSP + objectMemory wordSize].
- [theSP := theSP + BytesPerWord].
[frameRcvrOffset := self frameReceiverOffset: theFP.
[theSP <= frameRcvrOffset] whileTrue:
[oop := stackPages longAt: theSP.
(objectMemory isIntegerObject: oop) ifFalse:
[ok := ok & (self checkOkayFields: oop)].
+ theSP := theSP + objectMemory wordSize].
- theSP := theSP + BytesPerWord].
(self frameHasContext: theFP) ifTrue:
[self assert: (objectMemory isContext: (self frameContext: theFP)).
ok := ok & (self checkOkayFields: (self frameContext: theFP))].
ok := ok & (self checkOkayFields: (self frameMethodObject: theFP)).
(callerFP := self frameCallerFP: theFP) ~= 0] whileTrue:
+ [theSP := theFP + FoxCallerSavedIP + objectMemory wordSize.
- [theSP := theFP + FoxCallerSavedIP + BytesPerWord.
theFP := callerFP].
theSP := self isCog
+ ifTrue: [theFP + FoxCallerSavedIP + objectMemory wordSize] "caller ip is ceBaseReturnPC"
- ifTrue: [theFP + FoxCallerSavedIP + 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:
[ok := ok & (self checkOkayFields: oop)].
+ theSP := theSP + objectMemory wordSize].
- theSP := theSP + BytesPerWord].
^ok!
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 + objectMemory wordSize].
- [theSP := theSP + BytesPerWord].
[[theSP <= (theFP + FoxReceiver)] whileTrue:
[oop := stackPages longAt: theSP.
((objectMemory isNonImmediate: oop)
and: [(objectMemory heapMapAtWord: (self pointerForOop: oop)) = 0]) ifTrue:
[self printFrameThing: 'object leak in frame temp' andFrame: theFP at: theSP.
ok := false].
+ theSP := theSP + objectMemory wordSize].
- theSP := theSP + BytesPerWord].
(self frameHasContext: theFP) ifTrue:
[oop := self frameContext: theFP.
((objectMemory isImmediate: oop)
or: [(objectMemory heapMapAtWord: (self pointerForOop: oop)) = 0]) ifTrue:
[self printFrameThing: 'object leak in frame ctxt' andFrame: theFP at: theFP + FoxThisContext.
ok := false].
(objectMemory isContext: oop) ifFalse:
[self printFrameThing: 'frame ctxt should be context' andFrame: theFP at: theFP + FoxThisContext.
ok := false].
((objectMemory isContext: oop) and: [self isMarriedOrWidowedContext: oop]) ifFalse:
[self printFrameThing: 'frame ctxt should be married' andFrame: theFP at: theFP + FoxThisContext.
ok := false].
((objectMemory isContext: oop)
and: [(self isMarriedOrWidowedContext: oop)
and: [(self frameOfMarriedContext: oop) = theFP]]) ifFalse:
[self printFrameThing: 'frame ctxt should be married to this frame ' andFrame: theFP at: theFP + FoxThisContext.
ok := false]].
oop := self frameMethod: theFP.
((objectMemory isImmediate: oop)
or: [(objectMemory heapMapAtWord: (self pointerForOop: oop)) = 0]) ifTrue:
[self printFrameThing: 'object leak in frame mthd' andFrame: theFP at: theFP + FoxMethod.
ok := false].
(callerFP := self frameCallerFP: theFP) ~= 0] whileTrue:
+ [theSP := theFP + FoxCallerSavedIP + objectMemory wordSize.
- [theSP := theFP + FoxCallerSavedIP + BytesPerWord.
theFP := callerFP].
+ theSP := theFP + FoxCallerSavedIP + objectMemory wordSize.
- theSP := theFP + FoxCallerSavedIP + BytesPerWord.
[theSP <= thePage baseAddress] whileTrue:
[oop := stackPages longAt: theSP.
((objectMemory isNonImmediate: oop)
and: [(objectMemory heapMapAtWord: (self pointerForOop: oop)) = 0]) ifTrue:
[self printFrameThing: 'object leak in frame arg' andFrame: theFP at: theSP.
ok := false].
+ theSP := theSP + objectMemory wordSize]]].
- theSP := theSP + BytesPerWord]]].
^ok!
Item was changed:
----- Method: StackInterpreter>>commonReturn (in category 'return bytecodes') -----
commonReturn
"Do an ^-return (return form method), perhaps checking for unwinds if this is a block activation.
Note: Assumed to be inlined into the dispatch loop."
<sharedCodeInCase: #returnReceiver>
| 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 *'>
"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.
((objectMemory 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: (objectMemory isContext: currentCtx).
stackPages freeStackPage: stackPage.
[self assert: (objectMemory 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.
stackPages 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) - objectMemory wordSize].
- localSP := (self frameCallerSP: callerFP) - BytesPerWord].
self setMethod: (self frameMethod: localFP).
self fetchNextBytecode.
self internalStackTopPut: localReturnValue!
Item was changed:
----- Method: StackInterpreter>>computeStackZoneSize (in category 'initialization') -----
computeStackZoneSize
+ self cCode: [] inSmalltalk:
+ [stackPages ifNil:
+ [stackPages := self stackPagesClass new setInterpreter: self]].
- self cCode: []
- inSmalltalk: [stackPages ifNil: [stackPages := self stackPagesClass new]].
^numStackPages * ((self sizeof: InterpreterStackPage) + self stackPageByteSize)
+ stackPages extraStackBytes!
Item was changed:
----- Method: StackInterpreter>>contextInstructionPointer:frame: (in category 'frame access') -----
contextInstructionPointer: theIP frame: theFP
<var: #theFP type: #'char *'>
self assert: (self validInstructionPointer: theIP + 1 inFrame: theFP).
+ ^objectMemory integerObjectOf: theIP - (self iframeMethod: theFP) - objectMemory baseHeaderSize + 2!
- ^objectMemory integerObjectOf: theIP - (self iframeMethod: theFP) - BaseHeaderSize + 2!
Item was changed:
----- Method: StackInterpreter>>convertFloatsToPlatformOrder (in category 'image save/restore') -----
convertFloatsToPlatformOrder
"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."
objectMemory vmEndianness = imageFloatsBigEndian ifTrue:
[^nil].
self assert: ClassFloatCompactIndex ~= 0.
objectMemory allObjectsDo:
[:obj| | temp |
(objectMemory compactClassIndexOf: obj) = ClassFloatCompactIndex ifTrue:
+ [temp := self longAt: obj + objectMemory baseHeaderSize.
+ self longAt: obj + objectMemory baseHeaderSize put: (self longAt: obj + objectMemory baseHeaderSize + 4).
+ self longAt: obj + objectMemory baseHeaderSize + 4 put: temp]]!
- [temp := self longAt: obj + BaseHeaderSize.
- self longAt: obj + BaseHeaderSize put: (self longAt: obj + BaseHeaderSize + 4).
- self longAt: obj + BaseHeaderSize + 4 put: temp]]!
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 isImmediate: messageSelector) or: [objectMemory addressCouldBeObj: messageSelector]).
objectMemory hasSpurMemoryManagerAPI
ifTrue:
[argumentArray := objectMemory
eeInstantiateSmallClassIndex: ClassArrayCompactIndex
format: objectMemory arrayFormat
numSlots: argumentCount.
message := objectMemory
eeInstantiateSmallClassIndex: ClassMessageCompactIndex
format: objectMemory nonIndexablePointerFormat
numSlots: MessageLookupClassIndex + 1]
ifFalse:
[argumentArray := objectMemory
eeInstantiateSmallClass: (objectMemory splObj: ClassArray)
numSlots: argumentCount.
message := objectMemory
eeInstantiateSmallClass: (objectMemory splObj: ClassMessage)
numSlots: MessageLookupClassIndex + 1].
"Since the array is new can use unchecked stores."
+ (argumentCount - 1) * objectMemory bytesPerOop to: 0 by: objectMemory bytesPerOop negated do:
- (argumentCount - 1) * BytesPerOop to: 0 by: BytesPerOop negated do:
[:i|
self longAt: argumentArray + objectMemory baseHeaderSize + i put: self popStack].
"Since message is new can use unchecked stores."
objectMemory
storePointerUnchecked: MessageSelectorIndex ofObject: message withValue: messageSelector;
storePointerUnchecked: MessageArgumentsIndex ofObject: message withValue: argumentArray;
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 isNonImmediate: oop)
and: [(objectMemory fetchClassOfNonImm: oop) = (objectMemory splObj: ClassFloat)]) ifTrue:
[self cCode: '' inSmalltalk: [result := Float new: 2].
+ objectMemory fetchFloatAt: oop + objectMemory baseHeaderSize into: result.
- objectMemory fetchFloatAt: oop + BaseHeaderSize into: result.
^result].
^nil!
Item was changed:
----- Method: StackInterpreter>>divorceAllFrames (in category 'frame access') -----
divorceAllFrames
| activeContext |
<inline: false>
<var: #aPage type: #'StackPage *'>
stackPage ~= 0 ifTrue:
[self externalWriteBackHeadFramePointers].
activeContext := self
ensureFrameIsMarried: framePointer
+ SP: stackPointer + objectMemory wordSize.
- SP: stackPointer + BytesPerWord.
0 to: numStackPages - 1 do:
[:i| | aPage |
aPage := stackPages stackPageAt: i.
(stackPages isFree: aPage) ifFalse:
[self divorceFramesIn: aPage]].
self zeroStackPage.
^activeContext!
Item was changed:
----- Method: StackInterpreter>>divorceFramesIn: (in category 'frame access') -----
divorceFramesIn: aStackPage
| theFP calleeFP theSP theIP calleeContext theContext |
<inline: false>
<var: #aStackPage type: #'StackPage *'>
<var: #theFP type: #'char *'>
<var: #calleeFP type: #'char *'>
<var: #theSP type: #'char *'>
statStackPageDivorce := statStackPageDivorce + 1.
theFP := aStackPage headFP.
theSP := aStackPage headSP.
theIP := stackPages longAt: theSP.
+ theSP := theSP + objectMemory wordSize. "theSP points at hottest item on frame's stack"
- theSP := theSP + 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 << ((objectMemory wordSize * 8) - 8))
+ + (hasContext ifTrue: [1 << ((objectMemory wordSize * 8) - 16)] ifFalse: [0])
+ + (isBlock ifTrue: [1 << ((objectMemory wordSize * 8) - 24)] ifFalse: [0])]
- + (numArgs << ((BytesPerWord * 8) - 8))
- + (hasContext ifTrue: [1 << ((BytesPerWord * 8) - 16)] ifFalse: [0])
- + (isBlock ifTrue: [1 << ((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>>ensureCallerContext: (in category 'frame access') -----
ensureCallerContext: theFP
"Answerr the caller context for a frame. If the frame has a caller
frame that doesn't have a context, then marry the caller frame."
| callerFP |
<inline: true>
<var: #theFP type: #'char *'>
<var: #callerFP type: #'char *'>
- <asmLabel: false>
callerFP := self frameCallerFP: theFP.
callerFP = 0 ifTrue: "base frame, context in saved ip slot (or base of stack in Cog)"
[^self frameCallerContext: theFP].
^self ensureFrameIsMarried: callerFP SP: (self frameCallerStackPointer: theFP)!
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: (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) - objectMemory wordSize.
- callerSP := (self frameCallerSP: theFP) - BytesPerWord.
stackPages longAt: callerSP put: callerIP.
self setHeadFP: callerFP andSP: callerSP inPage: thePage]
!
Item was changed:
----- Method: StackInterpreter>>externalWriteBackHeadFramePointers (in category 'stack pages') -----
externalWriteBackHeadFramePointers
+ self assert: (framePointer - stackPointer) < (LargeContextSlots * objectMemory bytesPerOop).
- <asmLabel: false>
- self assert: (framePointer - stackPointer) < LargeContextSize.
self assert: stackPage = stackPages mostRecentlyUsedPage.
self setHeadFP: framePointer andSP: stackPointer inPage: stackPage.
self assert: stackPages pageListIsWellFormed!
Item was changed:
----- Method: StackInterpreter>>externalizeFPandSP (in category 'utilities') -----
externalizeFPandSP
"Copy the frame and stack pointers to global variables for use in primitives and other functions outside the interpret loop."
self assert: (localSP < stackPage baseAddress
+ and: [localSP > (stackPage realStackLimit - (LargeContextSlots * objectMemory bytesPerOop))]).
- and: [localSP > (stackPage realStackLimit - LargeContextSize)]).
stackPointer := localSP.
framePointer := localFP!
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: #theFP type: #'char *'>
<var: #thePage type: #'StackPage *'>
<var: #startFrame type: #'char *'>
<returnTypeC: #'char *'>
| aFrame prevFrame |
<inline: true>
- <asmLabel: false>
<var: #aFrame type: #'char *'>
<var: #prevFrame type: #'char *'>
self assert: (stackPages isFree: thePage) not.
startFrame = theFP ifTrue:
[thePage headSP >= startFrame 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: [thePage headSP]
+ ifFalse: [thePage headSP + objectMemory wordSize]].
- ifFalse: [thePage headSP + BytesPerWord]].
aFrame := startFrame.
[prevFrame := aFrame.
aFrame := self frameCallerFP: aFrame.
aFrame ~= 0] whileTrue:
[theFP = aFrame ifTrue:
[^self frameCallerSP: prevFrame]].
^nil!
Item was changed:
----- Method: StackInterpreter>>firstByteIndexOfMethod: (in category 'compiled methods') -----
firstByteIndexOfMethod: methodObj
"Answer the one-relative index of the first bytecode in methodObj.
Used for safer bounds-checking on methods."
+ ^(objectMemory literalCountOf: methodObj) + LiteralStart * objectMemory bytesPerOop + 1!
- ^(objectMemory literalCountOf: methodObj) + LiteralStart * BytesPerOop + 1!
Item was changed:
----- Method: StackInterpreter>>floatObjectOf: (in category 'object format') -----
floatObjectOf: aFloat
| newFloatObj |
<inline: false>
<var: #aFloat type: #double>
newFloatObj := objectMemory
eeInstantiateSmallClassIndex: ClassFloatCompactIndex
format: objectMemory firstLongFormat
+ numSlots: (self sizeof: #double) / objectMemory bytesPerOop.
- numSlots: 8 / objectMemory wordSize.
objectMemory storeFloatAt: newFloatObj + objectMemory baseHeaderSize from: aFloat.
^newFloatObj!
Item was changed:
----- Method: StackInterpreter>>floatValueOf: (in category 'utilities') -----
floatValueOf: oop
"Answer the C double precision floating point value of the argument,
or fail if it is not a Float, and answer 0.
Note: May be called by translated primitive code."
| isFloat result |
- <asmLabel: false>
<returnTypeC: #double>
<var: #result type: #double>
isFloat := self isInstanceOfClassFloat: oop.
isFloat ifTrue:
[self cCode: '' inSmalltalk: [result := Float new: 2].
objectMemory fetchFloatAt: oop + objectMemory baseHeaderSize into: result.
^result].
self primitiveFail.
^0.0!
Item was changed:
----- Method: StackInterpreter>>followForwardedFrameContents:stackPointer: (in category 'lazy become') -----
followForwardedFrameContents: theFP stackPointer: theSP
"follow pointers in the current stack frame up to theSP."
<var: #theFP type: #'char *'>
<var: #theSP type: #'char *'>
<var: #ptr type: #'char *'>
theFP + (self frameStackedReceiverOffset: theFP)
+ to: theFP + FoxCallerSavedIP + objectMemory wordSize
+ by: objectMemory wordSize
- to: theFP + FoxCallerSavedIP + BytesPerWord
- by: BytesPerWord
do: [:ptr| | oop |
oop := stackPages longAt: ptr.
((objectMemory isNonImmediate: oop)
and: [objectMemory isForwarded: oop]) ifTrue:
[stackPages longAt: ptr put: (objectMemory followForwarded: oop)]].
theSP
to: (self frameReceiverOffset: theFP)
+ by: objectMemory wordSize
- by: BytesPerWord
do: [:ptr| | oop |
oop := stackPages longAt: ptr.
((objectMemory isNonImmediate: oop)
and: [objectMemory isForwarded: oop]) ifTrue:
[stackPages longAt: ptr put: (objectMemory followForwarded: oop)]].
self assert: (objectMemory isForwarded: (self frameMethodObject: theFP)) not.
(self frameHasContext: theFP) ifTrue:
[self assert: (objectMemory isForwarded: (self frameContext: theFP)) not]!
Item was changed:
----- Method: StackInterpreter>>followForwardingPointersInStackZone: (in category 'object memory support') -----
followForwardingPointersInStackZone: theBecomeEffectsFlags
"Spur's become: is lazy, turning the becommed object into a forwarding object to the other.
The read-barrier is minimised by arranging that forwarding pointers will fail a method cache
probe, since notionally objects' internals are accessed only via sending messages to them,
the exception is primitives that access the internals of the non-receiver argument(s).
To avoid a read barrier on bytecode, literal and inst var fetch we scan the receivers and
methods in the stack zone and follow any forwarded ones. This is of course way cheaper
than scanning all of memory as in the old become."
| theIPPtr |
<inline: false>
<var: #thePage type: #'StackPage *'>
<var: #theSP type: #'char *'>
<var: #theFP type: #'char *'>
<var: #callerFP type: #'char *'>
<var: #theIPPtr type: #usqInt>
(theBecomeEffectsFlags anyMask: BecameCompiledMethodFlag) ifTrue:
[(objectMemory isForwarded: method) ifTrue:
[theIPPtr := instructionPointer - method.
method := objectMemory followForwarded: method.
instructionPointer := method + theIPPtr].
(objectMemory isForwarded: newMethod) ifTrue:
[newMethod := objectMemory followForwarded: newMethod]].
self assert: stackPage ~= 0.
0 to: numStackPages - 1 do:
[:i| | thePage theSP theFP callerFP 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 asUnsignedInteger.
+ theSP := theSP + objectMemory wordSize].
- theSP := theSP + BytesPerWord].
[self assert: (thePage addressIsInPage: theFP).
self assert: (theIPPtr = 0 or: [thePage addressIsInPage: theIPPtr asVoidPointer]).
oop := stackPages longAt: theFP + FoxReceiver.
(objectMemory isOopForwarded: oop) ifTrue:
[stackPages
longAt: theFP + FoxReceiver
put: (objectMemory followForwarded: oop)].
theIP := (theFP + (self frameStackedReceiverOffset: theFP)) asUnsignedInteger. "reuse theIP; its just an offset here"
oop := stackPages longAt: theIP.
(objectMemory isOopForwarded: oop) ifTrue:
[stackPages
longAt: theIP
put: (objectMemory followForwarded: oop)].
((self frameHasContext: theFP)
and: [(objectMemory isForwarded: (self frameContext: theFP))]) ifTrue:
[stackPages
longAt: theFP + FoxThisContext
put: (objectMemory followForwarded: (self frameContext: theFP))].
oop := self frameMethod: theFP.
(objectMemory isForwarded: oop) ifTrue:
[| newOop delta |
newOop := objectMemory followForwarded: oop.
theIPPtr ~= 0 ifTrue:
[self assert: (stackPages longAt: theIPPtr) > (self frameMethod: theFP).
delta := newOop - oop.
stackPages
longAt: theIPPtr
put: (stackPages longAt: theIPPtr) + delta].
stackPages
longAt: theFP + FoxMethod
put: (oop := newOop)].
(callerFP := self frameCallerFP: theFP) ~= 0] whileTrue:
[theIPPtr := (theFP + FoxCallerSavedIP) asUnsignedInteger.
theFP := callerFP]]]!
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) + objectMemory wordSize!
- ^theFP + (self frameStackedReceiverOffset: theFP) + 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) + objectMemory wordSize!
- ^theFP + (self frameStackedReceiverOffset: theFP) + BytesPerWord!
Item was changed:
----- Method: StackInterpreter>>frameStackedReceiverOffsetNumArgs: (in category 'frame access') -----
frameStackedReceiverOffsetNumArgs: numArgs
"Answer the offset in bytes from the a frame pointer to its stacked receiver,
given the 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>
+ ^FoxCallerSavedIP + objectMemory wordSize + (numArgs << objectMemory shiftForWord)!
- ^FoxCallerSavedIP + BytesPerWord + (numArgs << 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) // objectMemory wordSize) ifTrue:
- primFailCode <= ((objectMemory lastPointerOf: table) // BytesPerWord) ifTrue:
[^objectMemory fetchPointer: primFailCode - 1 ofObject: table]].
^objectMemory integerObjectOf: primFailCode!
Item was changed:
----- Method: StackInterpreter>>handleForwardedSendFaultForTag: (in category 'message sending') -----
handleForwardedSendFaultForTag: classTag
"Handle a send fault that may be due to a send to a forwarded object.
Unforward the receiver on the stack and answer its actual class."
<option: #SpurObjectMemory>
| rcvr |
<inline: false>
self assert: (objectMemory isForwardedClassTag: classTag).
rcvr := self stackValue: argumentCount.
"should *not* be a super send, so the receiver should be forwarded."
self assert: (objectMemory isOopForwarded: rcvr).
rcvr := objectMemory followForwarded: rcvr.
self stackValue: argumentCount put: rcvr.
self followForwardedFrameContents: framePointer
+ stackPointer: stackPointer + (argumentCount + 1 * objectMemory wordSize). "don't repeat effort"
- stackPointer: stackPointer + (argumentCount + 1 * BytesPerWord). "don't repeat effort"
(objectMemory isPointers: (self frameReceiver: framePointer)) ifTrue:
[objectMemory
followForwardedObjectFields: (self frameReceiver: framePointer)
toDepth: 0].
^objectMemory fetchClassTagOf: rcvr!
Item was changed:
----- Method: StackInterpreter>>highBit: (in category 'stack pages') -----
highBit: anUnsignedValue
"This is a C implementation needed by ioSetMaxExtSemTableSize
and e.g. stackPageByteSize."
| shifted bitNo |
<api>
<highBit> "so it shows up in senders..."
<var: #anUnsignedValue type: #usqInt>
<var: #shifted type: #usqInt>
shifted := anUnsignedValue.
bitNo := 0.
+ self cppIf: objectMemory wordSize > 4
- self cppIf: 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>>iframeInstructionPointerForIndex:method: (in category 'frame access') -----
iframeInstructionPointerForIndex: ip method: aMethod
"Answer the instruction pointer for use in an interpreter frame (a pointer to a bytecode)."
+ self assert: (ip between: (((LiteralStart + (objectMemory literalCountOf: aMethod)) * objectMemory bytesPerOop)) + 1
- self assert: (ip between: (((LiteralStart + (objectMemory literalCountOf: aMethod)) * BytesPerOop)) + 1
and: (objectMemory lengthOf: aMethod)).
^aMethod + ip + objectMemory baseHeaderSize - 2!
Item was changed:
----- Method: StackInterpreter>>imageFormatCompatibilityVersion (in category 'image save/restore') -----
imageFormatCompatibilityVersion
"This VM is backward-compatible with the immediately preceeding version."
+ ^objectMemory wordSize == 4 ifTrue: [6504] ifFalse: [68002]!
- ^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."
| isSpurFlag |
isSpurFlag := objectMemory hasSpurMemoryManagerAPI ifTrue: [2r10000] ifFalse: [0].
+ ^(objectMemory wordSize = 4 ifTrue: [6505] ifFalse: [68003])
- ^(BytesPerWord = 4 ifTrue: [6505] ifFalse: [68003])
+ isSpurFlag!
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: [self alloca: stackPagesBytes]
inSmalltalk: [stackPages initializeWithByteSize: stackPagesBytes for: self].
self cCode: [self me: theStackMemory ms: 0 et: stackPagesBytes].
stackPages
initializeStack: theStackMemory
+ numSlots: stackPagesBytes / objectMemory wordSize
+ pageSize: stackPageBytes / objectMemory wordSize!
- numSlots: stackPagesBytes / BytesPerWord
- pageSize: stackPageBytes / BytesPerWord!
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: [self alloca: stackPagesBytes]
inSmalltalk: [stackPages initializeWithByteSize: stackPagesBytes for: self].
self cCode: [self me: theStackMemory ms: 0 et: stackPagesBytes].
stackPages
initializeStack: theStackMemory
+ numSlots: stackPagesBytes / objectMemory wordSize
+ pageSize: stackPageBytes / objectMemory wordSize.
- numSlots: stackPagesBytes / BytesPerWord
- pageSize: stackPageBytes / BytesPerWord.
"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 added:
+ ----- Method: StackInterpreter>>initializeFrameIndices (in category 'as yet unclassified') -----
+ 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 * objectMemory wordSize.
+ "In base frames the caller saved ip field holds the caller context."
+ FoxCallerContext := FoxCallerSavedIP.
+ FoxSavedFP := fxSavedFP * objectMemory wordSize.
+ FoxMethod := fxMethod * objectMemory wordSize.
+ FoxFrameFlags := fxFrameFlags * objectMemory wordSize.
+ FoxThisContext := fxThisContext * objectMemory wordSize.
+ FoxReceiver := fxReceiver * objectMemory wordSize!
Item was changed:
----- Method: StackInterpreter>>inlineLookupInMethodCacheSel:classTag: (in category 'method lookup cache') -----
inlineLookupInMethodCacheSel: selector classTag: classTag
"This method implements a simple method lookup cache. If an entry for the given selector and classTag is
found in the cache, set the values of 'newMethod' and 'primitiveFunctionPointer' and answer true. Otherwise,
answer false."
"About the re-probe scheme: The hash is the low bits of the XOR of two large addresses, minus their useless
lowest two bits. If a probe doesn't get a hit, the hash is shifted right one bit to compute the next probe,
introducing a new randomish bit. The cache is probed CacheProbeMax times before giving up."
"WARNING: Since the hash computation is based on the object addresses of the class and selector, we must
rehash or flush when compacting storage. We've chosen to flush, since that also saves the trouble of updating
the addresses of the objects in the cache."
"classTag is either a class object, if using NewObjectMemory, or a classIndex, if using SpurMemoryManager."
| hash probe |
<inline: true>
- <asmLabel: false>
hash := selector bitXor: classTag. "shift drops two low-order zeros from addresses"
probe := hash bitAnd: MethodCacheMask. "first probe"
(((methodCache at: probe + MethodCacheSelector) = selector) and:
[(methodCache at: probe + MethodCacheClass) = classTag]) ifTrue:
[newMethod := methodCache at: probe + MethodCacheMethod.
primitiveFunctionPointer := self cCoerceSimple: (methodCache at: probe + MethodCachePrimFunction)
to: #'void (*)()'.
^true "found entry in cache; done"].
probe := (hash >> 1) bitAnd: MethodCacheMask. "second probe"
(((methodCache at: probe + MethodCacheSelector) = selector) and:
[(methodCache at: probe + MethodCacheClass) = classTag]) ifTrue:
[newMethod := methodCache at: probe + MethodCacheMethod.
primitiveFunctionPointer := self cCoerceSimple: (methodCache at: probe + MethodCachePrimFunction)
to: #'void (*)()'.
^true "found entry in cache; done"].
probe := (hash >> 2) bitAnd: MethodCacheMask.
(((methodCache at: probe + MethodCacheSelector) = selector) and:
[(methodCache at: probe + MethodCacheClass) = classTag]) ifTrue:
[newMethod := methodCache at: probe + MethodCacheMethod.
primitiveFunctionPointer := self cCoerceSimple: (methodCache at: probe + MethodCachePrimFunction)
to: #'void (*)()'.
^true "found entry in cache; done"].
^false!
Item was changed:
----- Method: StackInterpreter>>internalPop: (in category 'internal interpreter access') -----
internalPop: nItems
"In the StackInterpreter stacks grow down."
+ localSP := localSP + (nItems * objectMemory bytesPerOop)!
- localSP := localSP + (nItems * BytesPerOop)!
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) * objectMemory bytesPerOop)) put: oop!
- stackPages longAtPointer: (localSP := localSP + ((nItems - 1) * BytesPerOop)) 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 + objectMemory bytesPerOop.
- localSP := localSP + BytesPerOop.
^top!
Item was changed:
----- Method: StackInterpreter>>internalPush: (in category 'internal interpreter access') -----
internalPush: object
"In the StackInterpreter stacks grow down."
+ stackPages longAtPointer: (localSP := localSP - objectMemory bytesPerOop) put: object!
- stackPages longAtPointer: (localSP := localSP - BytesPerOop) 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 * objectMemory bytesPerOop)!
- ^stackPages longAtPointer: localSP + (offset * BytesPerOop)!
Item was changed:
----- Method: StackInterpreter>>internalStackValue:put: (in category 'internal interpreter access') -----
internalStackValue: offset put: aValue
"In the StackInterpreter stacks grow down."
+ ^stackPages longAtPointer: localSP + (offset * objectMemory bytesPerOop) put: aValue!
- ^stackPages longAtPointer: localSP + (offset * BytesPerOop) put: aValue!
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."
| maxUsedBytesPerPage maxFramesPerPage |
maxUsedBytesPerPage := self stackPageFrameBytes + self stackLimitOffset.
+ maxFramesPerPage := maxUsedBytesPerPage / objectMemory wordSize // FrameSlots.
+ ^maxFramesPerPage * LargeContextSlots * objectMemory bytesPerOop * numStackPages!
- maxFramesPerPage := maxUsedBytesPerPage / BytesPerWord // FrameSlots.
- ^maxFramesPerPage * LargeContextSlots * BytesPerOop * numStackPages!
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."
<inline: true>
- <asmLabel: false>
<returnTypeC: #double>
(objectMemory isIntegerObject: floatOrInt) ifTrue:
[^(objectMemory integerValueOf: floatOrInt) asFloat].
^self floatValueOf: floatOrInt!
Item was changed:
----- Method: StackInterpreter>>longPrintOop: (in category 'debug printing') -----
longPrintOop: oop
<api>
| fmt lastIndex startIP bytecodesPerLine column |
((objectMemory isImmediate: oop)
or: [(objectMemory addressCouldBeObj: oop) not
or: [(oop bitAnd: objectMemory allocationUnit - 1) ~= 0
or: [(objectMemory isFreeObject: oop)
or: [objectMemory isForwarded: oop]]]]) ifTrue:
[self printOop: oop.
^self].
self printHex: oop.
(objectMemory fetchClassOfNonImm: oop)
ifNil: [self print: ' has a nil class!!!!']
ifNotNil: [:class|
self print: ': a(n) '; printNameOfClass: class count: 5;
print: ' ('.
objectMemory hasSpurMemoryManagerAPI ifTrue:
[self printHexnp: (objectMemory compactClassIndexOf: oop); print: '=>'].
self printHexnp: class; print: ')'].
fmt := objectMemory formatOf: oop.
self print: ' format '; printHexnp: fmt.
fmt > objectMemory lastPointerFormat
ifTrue: [self print: ' nbytes '; printNum: (objectMemory numBytesOf: oop)]
ifFalse: [(objectMemory isIndexableFormat: fmt) ifTrue:
[| len |
len := objectMemory lengthOf: oop.
self print: ' size '; printNum: len - (objectMemory fixedFieldsOf: oop format: fmt length: len)]].
objectMemory printHeaderTypeOf: oop.
self print: ' hash '; printHexnp: (objectMemory rawHashBitsOf: oop).
self cr.
(fmt between: objectMemory firstByteFormat and: objectMemory firstCompiledMethodFormat - 1) ifTrue:
[^self printStringOf: oop; cr].
(fmt between: objectMemory firstLongFormat and: objectMemory firstByteFormat - 1) ifTrue:
[0 to: ((objectMemory num32BitUnitsOf: oop) min: 256) - 1 do:
[:i| | fieldOop |
fieldOop := objectMemory fetchLong32: i ofObject: oop.
self space; printNum: i; space; printHex: fieldOop; space; cr].
^self].
"this is nonsense. apologies."
+ startIP := (objectMemory lastPointerOf: oop) + objectMemory bytesPerOop - objectMemory baseHeaderSize / objectMemory bytesPerOop.
- startIP := (objectMemory lastPointerOf: oop) + BytesPerOop - objectMemory baseHeaderSize / BytesPerOop.
lastIndex := 256 min: startIP.
lastIndex > 0 ifTrue:
[1 to: lastIndex do:
[:i| | fieldOop |
fieldOop := objectMemory fetchPointer: i - 1 ofObject: oop.
self space; printNum: i - 1; space; printHex: fieldOop; space.
(i = 1 and: [objectMemory isCompiledMethod: oop])
ifTrue: [self printMethodHeaderOop: fieldOop]
ifFalse: [self cCode: [self printOopShort: fieldOop]
inSmalltalk: [self print: (self shortPrint: fieldOop)]].
self cr]].
(objectMemory isCompiledMethod: oop)
ifFalse:
[startIP > 64 ifTrue: [self print: '...'; cr]]
ifTrue:
+ [startIP := startIP * objectMemory wordSize + 1.
- [startIP := startIP * BytesPerWord + 1.
lastIndex := objectMemory lengthOf: oop.
lastIndex - startIP > 100 ifTrue:
[lastIndex := startIP + 100].
bytecodesPerLine := 8.
column := 1.
startIP to: lastIndex do:
[:index| | byte |
column = 1 ifTrue:
[self cCode: 'printf("0x%08x: ", oop+BaseHeaderSize+index-1)'
+ inSmalltalk: [self print: (oop+objectMemory baseHeaderSize+index-1) hex; print: ': ']].
- inSmalltalk: [self print: (oop+BaseHeaderSize+index-1) hex; print: ': ']].
byte := objectMemory fetchByte: index - 1 ofObject: oop.
self cCode: 'printf(" %02x/%-3d", byte,byte)'
inSmalltalk: [self space; print: (byte radix: 16); printChar: $/; printNum: byte].
column := column + 1.
column > bytecodesPerLine ifTrue:
[column := 1. self cr]].
column = 1 ifFalse:
[self cr]]!
Item was changed:
----- Method: StackInterpreter>>lookupMethodFor:InDictionary: (in category 'message sending') -----
lookupMethodFor: selector InDictionary: dictionary
"Lookup the argument selector in aDictionary and answer either the
method or nil, if not found.
This method lookup tolerates integers as Dictionary keys to support
execution of images in which Symbols have been compacted out."
| length index mask wrapAround nextSelector methodArray |
<inline: true>
- <asmLabel: false>
length := objectMemory numSlotsOf: dictionary.
mask := length - SelectorStart - 1.
index := SelectorStart + (objectMemory methodDictionaryHash: selector mask: mask).
"It is assumed that there are some nils in this dictionary, and search will
stop when one is encountered. However, if there are no nils, then wrapAround
will be detected the second time the loop gets to the end of the table."
wrapAround := false.
[true] whileTrue:
[nextSelector := objectMemory fetchPointer: index ofObject: dictionary.
nextSelector = objectMemory nilObject ifTrue:
[^nil].
(objectMemory isOopForwarded: nextSelector) ifTrue:
[nextSelector := objectMemory
fixFollowedField: index + SelectorStart
ofObject: dictionary
withInitialValue: nextSelector].
nextSelector = selector ifTrue:
[methodArray := objectMemory followObjField: MethodArrayIndex ofObject: dictionary.
^objectMemory followField: index - SelectorStart ofObject: methodArray].
index := index + 1.
index = length ifTrue:
[wrapAround ifTrue: [^nil].
wrapAround := true.
index := SelectorStart]].
^nil "for Slang"!
Item was changed:
----- Method: StackInterpreter>>lookupMethodInClass: (in category 'message sending') -----
lookupMethodInClass: class
| currentClass dictionary found |
<inline: false>
self assert: (self addressCouldBeClassObj: class).
currentClass := class.
[currentClass ~= objectMemory nilObject] whileTrue:
[dictionary := objectMemory followObjField: 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 sendBreakpoint: 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 + objectMemory baseHeaderSize
- self sendBreak: messageSelector + BaseHeaderSize
point: (objectMemory lengthOf: messageSelector)
receiver: nil.
^self lookupMethodInClass: class!
Item was changed:
----- Method: StackInterpreter>>lookupMethodInDictionary: (in category 'message sending') -----
lookupMethodInDictionary: dictionary
"This method lookup tolerates integers as Dictionary keys to support
execution of images in which Symbols have been compacted out."
| length index mask wrapAround nextSelector methodArray |
<inline: true>
- <asmLabel: false>
length := objectMemory numSlotsOf: dictionary.
mask := length - SelectorStart - 1.
"Use linear search on small dictionaries; its cheaper.
Also the limit can be set to force linear search of all dictionaries, which supports the
booting of images that need rehashing (e.g. because a tracer has generated an image
with different hashes but hasn't rehashed it yet.)"
mask <= methodDictLinearSearchLimit ifTrue:
[index := 0.
[index <= mask] whileTrue:
[nextSelector := objectMemory fetchPointer: index + SelectorStart ofObject: dictionary.
(objectMemory isOopForwarded: nextSelector) ifTrue:
[nextSelector := objectMemory
fixFollowedField: index + SelectorStart
ofObject: dictionary
withInitialValue: nextSelector].
nextSelector = messageSelector ifTrue:
[methodArray := objectMemory followObjField: MethodArrayIndex ofObject: dictionary.
newMethod := objectMemory followField: index ofObject: methodArray.
^true].
index := index + 1].
^false].
index := SelectorStart + (objectMemory methodDictionaryHash: messageSelector mask: mask).
"It is assumed that there are some nils in this dictionary, and search will
stop when one is encountered. However, if there are no nils, then wrapAround
will be detected the second time the loop gets to the end of the table."
wrapAround := false.
[true] whileTrue:
[nextSelector := objectMemory fetchPointer: index ofObject: dictionary.
nextSelector = objectMemory nilObject ifTrue: [^false].
(objectMemory isOopForwarded: nextSelector) ifTrue:
[nextSelector := objectMemory
fixFollowedField: index + SelectorStart
ofObject: dictionary
withInitialValue: nextSelector].
nextSelector = messageSelector ifTrue:
[methodArray := objectMemory followObjField: MethodArrayIndex ofObject: dictionary.
newMethod := objectMemory followField: index - SelectorStart ofObject: methodArray.
^true].
index := index + 1.
index = length ifTrue:
[wrapAround ifTrue: [^false].
wrapAround := true.
index := SelectorStart]].
^false "for Slang"!
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."
<returnTypeC: #'StackPage *'>
| page pointer theMethod theIP numArgs stackPtrIndex maybeClosure rcvr |
<inline: false>
<var: #page type: #'StackPage *'>
<var: #pointer type: #'char *'>
self assert: (self isSingleContext: aContext).
self assert: (objectMemory goodContextSize: aContext).
page := self newStackPage.
pointer := page baseAddress.
theIP := objectMemory fetchPointer: InstructionPointerIndex ofObject: aContext.
theMethod := objectMemory followObjField: MethodIndex ofObject: aContext.
(objectMemory isIntegerObject: theIP) ifFalse:
[self error: 'context is not resumable'].
theIP := objectMemory integerValueOf: theIP.
rcvr := objectMemory followField: ReceiverIndex 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 followField: ClosureIndex ofObject: aContext.
maybeClosure ~= objectMemory nilObject
ifTrue:
[numArgs := self argumentCountOfClosure: maybeClosure.
stackPages longAt: pointer put: maybeClosure]
ifFalse:
[| header |
header := objectMemory methodHeaderOf: theMethod.
numArgs := self argumentCountOfMethodHeader: header.
"If this is a synthetic context its IP could be pointing at the CallPrimitive opcode. If so, skip it."
(theIP signedIntFromLong > 0
and: [(self methodHeaderHasPrimitive: header)
and: [theIP = (1 + (objectMemory lastPointerOf: theMethod))]]) ifTrue:
[theIP := theIP + (self sizeOfCallPrimitiveBytecode: header)].
stackPages longAt: pointer put: rcvr].
"Put the arguments on the stack"
1 to: numArgs do:
[:i|
stackPages
+ longAt: (pointer := pointer - objectMemory wordSize)
- longAt: (pointer := pointer - BytesPerWord)
put: (objectMemory fetchPointer: ReceiverIndex + i ofObject: aContext)].
"saved caller ip is sender context in base frame"
stackPages
+ longAt: (pointer := pointer - objectMemory wordSize)
- longAt: (pointer := pointer - BytesPerWord)
put: (objectMemory fetchPointer: SenderIndex ofObject: aContext).
"base frame's saved fp is null"
stackPages
+ longAt: (pointer := pointer - objectMemory wordSize)
- longAt: (pointer := pointer - BytesPerWord)
put: 0.
page baseFP: pointer; headFP: pointer.
stackPages
+ longAt: (pointer := pointer - objectMemory wordSize)
- longAt: (pointer := pointer - BytesPerWord)
put: theMethod.
stackPages
+ longAt: (pointer := pointer - objectMemory wordSize)
- longAt: (pointer := pointer - BytesPerWord)
put: (self encodeFrameFieldHasContext: true isBlock: maybeClosure ~= objectMemory nilObject numArgs: numArgs).
self assert: (self frameHasContext: page baseFP).
self assert: (self frameNumArgs: page baseFP) == numArgs.
stackPages
+ longAt: (pointer := pointer - objectMemory wordSize)
- longAt: (pointer := pointer - BytesPerWord)
put: aContext.
stackPages
+ longAt: (pointer := pointer - objectMemory wordSize)
- longAt: (pointer := pointer - BytesPerWord)
put: rcvr.
stackPtrIndex := self quickFetchInteger: StackPointerIndex ofObject: aContext.
self assert: ReceiverIndex + stackPtrIndex < (objectMemory lengthOf: aContext).
numArgs + 1 to: stackPtrIndex do:
[:i|
stackPages
+ longAt: (pointer := pointer - objectMemory wordSize)
- longAt: (pointer := pointer - BytesPerWord)
put: (objectMemory fetchPointer: ReceiverIndex + i ofObject: aContext)].
"top of stack is the instruction pointer"
theIP := self iframeInstructionPointerForIndex: theIP method: theMethod.
+ stackPages longAt: (pointer := pointer - objectMemory wordSize) put: theIP.
- stackPages longAt: (pointer := pointer - BytesPerWord) put: theIP.
page headSP: pointer.
self assert: (self context: aContext hasValidInversePCMappingOf: theIP in: page baseFP).
"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) plus SmallInteger tags."
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.
self assert: (self validStackPageBaseFrame: page).
^page!
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 *'>
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 + objectMemory wordSize].
- theSP := theSP + BytesPerWord].
[self assert: (thePage addressIsInPage: theFP).
self assert: (thePage addressIsInPage: theSP).
self assert: (theIPPtr = 0 or: [thePage addressIsInPage: theIPPtr]).
[theSP <= (theFP + FoxReceiver)] whileTrue:
[oop := stackPages longAt: theSP.
(objectMemory shouldRemapOop: oop) ifTrue:
[stackPages longAt: theSP put: (objectMemory remapObj: oop)].
+ theSP := theSP + objectMemory wordSize].
- theSP := theSP + BytesPerWord].
(self frameHasContext: theFP) ifTrue:
[(objectMemory shouldRemapObj: (self frameContext: theFP)) ifTrue:
[stackPages
longAt: theFP + FoxThisContext
put: (objectMemory remapObj: (self frameContext: theFP))].
"With SqueakV3 objectMemory can't assert since object body is yet to move."
objectMemory hasSpurMemoryManagerAPI ifTrue:
[self assert: ((self isMarriedOrWidowedContext: (self frameContext: theFP))
and: [(self frameOfMarriedContext: (self frameContext: theFP)) = theFP])]].
(objectMemory shouldRemapObj: (self frameMethod: theFP)) ifTrue:
[theIPPtr ~= 0 ifTrue:
[self assert: (stackPages longAt: theIPPtr) > (self frameMethod: theFP).
theIP := (stackPages longAt: theIPPtr) - (self frameMethod: theFP)].
stackPages
longAt: theFP + FoxMethod
put: (objectMemory remapObj: (self frameMethod: theFP)).
theIPPtr ~= 0 ifTrue:
[stackPages longAt: theIPPtr put: theIP + (self frameMethod: theFP)]].
(callerFP := self frameCallerFP: theFP) ~= 0] whileTrue:
+ [theSP := (theIPPtr := theFP + FoxCallerSavedIP) + objectMemory wordSize.
- [theSP := (theIPPtr := theFP + FoxCallerSavedIP) + BytesPerWord.
theFP := callerFP].
theSP := theFP + FoxCallerContext. "a.k.a. FoxCallerSavedIP"
[theSP <= thePage baseAddress] whileTrue:
[oop := stackPages longAt: theSP.
(objectMemory shouldRemapOop: oop) ifTrue:
[stackPages longAt: theSP put: (objectMemory remapObj: oop)].
+ theSP := theSP + objectMemory wordSize]]]!
- theSP := theSP + 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.
self assert: thePage trace ~= StackPageTraced.
thePage trace: StackPageTraced.
theSP := thePage headSP.
theFP := thePage headFP.
"Skip the instruction pointer on top of stack of inactive pages."
thePage = stackPage ifFalse:
+ [theSP := theSP + objectMemory wordSize].
- [theSP := theSP + BytesPerWord].
[frameRcvrOffset := self frameReceiverOffset: theFP.
[theSP <= frameRcvrOffset] whileTrue:
[oop := stackPages longAt: theSP.
(objectMemory isOopForwarded: oop) ifTrue:
[oop := objectMemory followForwarded: oop.
stackPages longAt: theSP put: oop].
(objectMemory isImmediate: oop) ifFalse:
[objectMemory markAndTrace: oop].
+ theSP := theSP + objectMemory wordSize].
- theSP := theSP + BytesPerWord].
(self frameHasContext: theFP) ifTrue:
[self assert: (objectMemory isContext: (self frameContext: theFP)).
objectMemory markAndTrace: (self frameContext: theFP)].
objectMemory markAndTrace: (self iframeMethod: theFP).
(callerFP := self frameCallerFP: theFP) ~= 0] whileTrue:
+ [theSP := theFP + FoxCallerSavedIP + objectMemory wordSize.
- [theSP := theFP + FoxCallerSavedIP + BytesPerWord.
theFP := callerFP].
theSP := theFP + FoxCallerSavedIP. "caller ip is frameCallerContext in a base frame"
[theSP <= thePage baseAddress] whileTrue:
[oop := stackPages longAt: theSP.
(objectMemory isOopForwarded: oop) ifTrue:
[oop := objectMemory followForwarded: oop.
stackPages longAt: theSP put: oop].
(objectMemory isImmediate: oop) ifFalse:
[objectMemory markAndTrace: oop].
+ theSP := theSP + objectMemory wordSize]!
- theSP := theSP + 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 state ."
| 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 * objectMemory wordSize)]
- ifTrue: [theSP := stackPointer + (stackDeltaForCurrentFrame * 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 + objectMemory wordSize].
- theSP := theSP + BytesPerWord].
"Finally check stacked receiver (closure field or duplicate of receiver) and arguments"
+ theSP := theFP + FoxCallerSavedIP + objectMemory wordSize.
- theSP := theFP + FoxCallerSavedIP + BytesPerWord.
rcvrOffset := theFP + (self frameStackedReceiverOffset: theFP).
[theSP <= rcvrOffset] whileTrue:
[anOop = (stackPages longAt: theSP) ifTrue:
[^true].
+ theSP := theSP + objectMemory wordSize].
- theSP := theSP + BytesPerWord].
^false!
Item was changed:
----- Method: StackInterpreter>>marryFrame:SP:copyTemps: (in category 'frame access') -----
marryFrame: theFP SP: theSP copyTemps: copyTemps
"Marry an unmarried frame. This means creating a spouse context
initialized with a subset of the frame's state that references the frame.
For the default closure implementation we do not need to copy temps.
Different closure implementations may require temps to be copied."
| theContext methodHeader numSlots numArgs numStack closureOrNil numTemps |
<inline: true>
<var: #theFP type: #'char *'>
<var: #theSP type: #'char *'>
self assert: (self frameHasContext: theFP) not.
"The SP is expected to be pointing at the last oop on the stack, not at the pc"
self assert: (objectMemory addressCouldBeOop: (stackPages longAt: theSP)).
methodHeader := objectMemory methodHeaderOf: (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. If copyTemps is false (as it
is in the default closure implementation) 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].
numSlots := (self methodHeaderIndicatesLargeFrame: methodHeader)
ifTrue: [LargeContextSlots]
ifFalse: [SmallContextSlots].
theContext := objectMemory eeInstantiateMethodContextSlots: numSlots.
self assert: numStack + ReceiverIndex <= numSlots.
"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).
"If copyTemps is false, 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) * objectMemory wordSize))].
- + ((numArgs - i + 1) * BytesPerWord))].
copyTemps ifTrue:
[numTemps := self frameNumTemps: theFP.
1 to: numTemps do:
[:i|
objectMemory storePointerUnchecked: ReceiverIndex + i + numArgs
ofObject: theContext
withValue: (self temporary: i - 1 in: theFP)].
numArgs := numArgs + numTemps].
numArgs + 1 to: numStack do:
[:i|
objectMemory storePointerUnchecked: ReceiverIndex + i
ofObject: theContext
withValue: objectMemory nilObject].
self setFrameContext: theFP to: theContext.
self setFrameHasContext: theFP.
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 + objectMemory wordSize.
- newSP := newPage baseAddress + BytesPerWord.
stackedReceiverOffset := self frameStackedReceiverOffset: theFP.
"First move the data. We will fix up frame pointers later."
theFP + stackedReceiverOffset
to: oldPage headSP
+ by: objectMemory wordSize negated
- by: BytesPerWord negated
do: [:source|
+ newSP := newSP - objectMemory wordSize.
- newSP := newSP - 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.
self assert: (callerFP < oldPage baseAddress
+ and: [callerFP > (oldPage realStackLimit - (LargeContextSlots * objectMemory bytesPerOop / 2))]).
- and: [callerFP > (oldPage realStackLimit - (LargeContextSize / 2))]).
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*objectMemory wordSize).
- stackPointer := stackPointer + (nItems*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) * objectMemory wordSize)) put: oop.
- stackPages longAt: (sp := stackPointer + ((nItems - 1) * 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) * objectMemory wordSize))
- longAt: (sp := stackPointer + ((nItems - 1) * BytesPerWord))
put: (objectMemory booleanObjectOf: trueOrFalse).
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) * objectMemory wordSize))
- longAt: (sp := stackPointer + ((nItems - 1) * 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) * objectMemory wordSize))
- longAt: (sp := stackPointer + ((nItems - 1) * BytesPerWord))
put: (objectMemory integerObjectOf: integerVal).
stackPointer := sp!
Item was changed:
----- Method: StackInterpreter>>popStack (in category 'internal interpreter access') -----
popStack
"In the StackInterpreter stacks grow down."
<api>
| top |
<inline: true>
top := stackPages longAt: stackPointer.
+ stackPointer := stackPointer + objectMemory wordSize.
- stackPointer := stackPointer + BytesPerWord.
^top!
Item was changed:
----- Method: StackInterpreter>>positive64BitIntegerFor: (in category 'primitive support') -----
positive64BitIntegerFor: integerValue
<var: 'integerValue' type: #sqLong>
"Answer a Large Positive Integer object for the given integer value. N.B. will *not* cause a GC."
| newLargeInteger highWord sz |
highWord := self cCode: 'integerValue >> 32' inSmalltalk: [integerValue >> 32]. "shift is coerced to usqInt otherwise"
highWord = 0 ifTrue:[^self positive32BitIntegerFor: integerValue].
sz := 5.
(highWord := highWord >> 8) = 0 ifFalse:[sz := sz + 1].
(highWord := highWord >> 8) = 0 ifFalse:[sz := sz + 1].
(highWord := highWord >> 8) = 0 ifFalse:[sz := sz + 1].
newLargeInteger := objectMemory
eeInstantiateSmallClassIndex: ClassLargePositiveIntegerCompactIndex
format: (objectMemory byteFormatForNumBytes: sz)
+ numSlots: 8 / objectMemory bytesPerOop.
- numSlots: 8 / objectMemory bytesPerSlot.
objectMemory
storeByte: 7 ofObject: newLargeInteger withValue: (integerValue >> 56 bitAnd: 16rFF);
storeByte: 6 ofObject: newLargeInteger withValue: (integerValue >> 48 bitAnd: 16rFF);
storeByte: 5 ofObject: newLargeInteger withValue: (integerValue >> 40 bitAnd: 16rFF);
storeByte: 4 ofObject: newLargeInteger withValue: (integerValue >> 32 bitAnd: 16rFF);
storeByte: 3 ofObject: newLargeInteger withValue: (integerValue >> 24 bitAnd: 16rFF);
storeByte: 2 ofObject: newLargeInteger withValue: (integerValue >> 16 bitAnd: 16rFF);
storeByte: 1 ofObject: newLargeInteger withValue: (integerValue >> 8 bitAnd: 16rFF);
storeByte: 0 ofObject: newLargeInteger withValue: (integerValue ">> 0" bitAnd: 16rFF).
^newLargeInteger
!
Item was changed:
----- Method: StackInterpreter>>preGCAction: (in category 'object memory support') -----
preGCAction: gcModeArg
- <asmLabel: false>
"Need to write back the frame pointers unless all pages are free (as in snapshot)"
stackPage ~= 0 ifTrue:
[self externalWriteBackHeadFramePointers].
(gcModeArg = GCModeFull
and: [objectMemory hasSpurMemoryManagerAPI]) ifTrue:
[self flushMethodCache]!
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 numSlotsOf: argumentArray.
arraySize > LargeContextSlots 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 sendBreakpoint: messageSelector receiver: actualReceiver.
self printSends ifTrue:
[self printActivationNameForSelector: messageSelector startClass: lookupClass; cr].
self findNewMethodInClassTag: (objectMemory classTagForClass: 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 := objectMemory wordSize * (performArgCount + 2). "+2 = receiver + saved newMethod"
+ argumentCount * objectMemory wordSize to: 0 by: objectMemory wordSize negated do:
- delta := BytesPerWord * (performArgCount + 2). "+2 = receiver + saved newMethod"
- argumentCount * BytesPerWord to: 0 by: 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
<api>
| 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) * objectMemory wordSize).
- at: theFP + FoxCallerSavedIP + ((numArgs + 1) * BytesPerWord).
numArgs to: 1 by: -1 do:
+ [:i| self printFrameOop: 'arg' at: theFP + FoxCallerSavedIP + (i * objectMemory wordSize)].
- [:i| self printFrameOop: 'arg' at: theFP + FoxCallerSavedIP + (i * 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 - objectMemory wordSize to: theSP + objectMemory wordSize by: objectMemory wordSize negated do:
- [theFP + FoxReceiver - BytesPerWord to: theSP + BytesPerWord by: BytesPerWord negated do:
[:addr|
self printFrameOop: 'temp/stck' at: addr].
self printFrameThing: 'frame ip' at: theSP]
ifFalse:
+ [theFP + FoxReceiver - objectMemory wordSize to: theSP by: objectMemory wordSize negated do:
- [theFP + FoxReceiver - BytesPerWord to: theSP by: BytesPerWord negated do:
[:addr|
self printFrameOop: 'temp/stck' at: addr]]!
Item was changed:
----- Method: StackInterpreter>>printOop: (in category 'debug printing') -----
printOop: oop
| cls fmt lastIndex startIP bytecodesPerLine column |
<inline: false>
(objectMemory isImmediate: oop) ifTrue:
[^self shortPrintOop: oop].
self printHex: oop.
(objectMemory addressCouldBeObj: oop) ifFalse:
[^self print: ((oop bitAnd: objectMemory allocationUnit - 1) ~= 0
ifTrue: [' is misaligned']
ifFalse: [self whereIs: oop]); cr].
(objectMemory isFreeObject: oop) ifTrue:
[^self print: ' is a free chunk of size '; printNum: (objectMemory sizeOfFree: oop); cr].
(objectMemory isForwarded: oop) ifTrue:
[^self
print: ' is a forwarded object to '; printHex: (objectMemory followForwarded: oop);
print: ' of slot size '; printNum: (objectMemory numSlotsOfAny: oop); cr].
self print: ': a(n) '.
self printNameOfClass: (cls := objectMemory fetchClassOfNonImm: oop) count: 5.
cls = (objectMemory splObj: ClassFloat) ifTrue:
[^self cr; printFloat: (self dbgFloatValueOf: oop); cr].
fmt := objectMemory formatOf: oop.
fmt > objectMemory lastPointerFormat ifTrue:
[self print: ' nbytes '; printNum: (objectMemory numBytesOf: oop)].
self cr.
(fmt between: objectMemory firstLongFormat and: objectMemory firstCompiledMethodFormat - 1) 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) asUnsignedInteger; cr].
(objectMemory isWords: oop) ifTrue:
+ [lastIndex := 64 min: ((objectMemory numBytesOf: oop) / objectMemory wordSize).
- [lastIndex := 64 min: ((objectMemory numBytesOf: oop) / 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]].
^self].
^self printStringOf: oop; cr].
"this is nonsense. apologies."
+ startIP := (objectMemory lastPointerOf: oop) + objectMemory bytesPerOop - objectMemory baseHeaderSize / objectMemory bytesPerOop.
- startIP := (objectMemory lastPointerOf: oop) + BytesPerOop - objectMemory baseHeaderSize / BytesPerOop.
lastIndex := 256 min: startIP.
lastIndex > 0 ifTrue:
[1 to: lastIndex do:
[:index|
self cCode: [self printHex: (objectMemory fetchPointer: index - 1 ofObject: oop); space]
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 * objectMemory wordSize + 1.
- [startIP := startIP * BytesPerWord + 1.
lastIndex := objectMemory lengthOf: oop.
lastIndex - startIP > 100 ifTrue:
[lastIndex := startIP + 100].
bytecodesPerLine := 8.
column := 1.
startIP to: lastIndex do:
[:index| | byte |
column = 1 ifTrue:
[self cCode: 'printf("0x%08x: ", oop+BaseHeaderSize+index-1)'
+ inSmalltalk: [self print: (oop+objectMemory baseHeaderSize+index-1) hex; print: ': ']].
- inSmalltalk: [self print: (oop+BaseHeaderSize+index-1) hex; print: ': ']].
byte := objectMemory fetchByte: index - 1 ofObject: oop.
self cCode: 'printf(" %02x/%-3d", byte,byte)'
inSmalltalk: [self space; print: (byte radix: 16); printChar: $/; printNum: byte].
column := column + 1.
column > bytecodesPerLine ifTrue:
[column := 1. self cr]].
column = 1 ifFalse:
[self cr]]!
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 - objectMemory wordSize) put: object.
- stackPages longAt: (sp := stackPointer - BytesPerWord) put: object.
stackPointer := sp!
Item was changed:
----- Method: StackInterpreter>>pushClosureNumArgs:copiedValues:blockSize: (in category 'stack bytecodes') -----
pushClosureNumArgs: numArgs copiedValues: numCopied blockSize: blockSize
"The compiler has pushed the values to be copied, if any.
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."
<inline: true>
| newClosure context |
"No need to record the pushed copied values in the outerContext."
+ context := self ensureFrameIsMarried: localFP SP: localSP + (numCopied * objectMemory bytesPerOop).
- context := self ensureFrameIsMarried: localFP SP: localSP + (numCopied * BytesPerOop).
newClosure := self
closureIn: context
numArgs: numArgs
+ instructionPointer: (self oopForPointer: localIP) + 2 - (method+objectMemory baseHeaderSize)
- instructionPointer: (self oopForPointer: localIP) + 2 - (method+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>>putToSleep:yieldingIf: (in category 'process primitive support') -----
putToSleep: aProcess yieldingIf: yieldImplicitly
"Save the given process on the scheduler process list for its priority,
adding to the back if yieldImplicitly or to the front if not yieldImplicitly."
| priority processLists processList |
+ self assert: (framePointer - stackPointer) < (LargeContextSlots * objectMemory bytesPerOop).
- self assert: (framePointer - stackPointer) < LargeContextSize.
priority := self quickFetchInteger: PriorityIndex ofObject: aProcess.
(highestRunnableProcessPriority ~= 0
and: [priority > highestRunnableProcessPriority]) ifTrue:
[highestRunnableProcessPriority := priority].
processLists := objectMemory fetchPointer: ProcessListsIndex ofObject: self schedulerPointer.
processList := objectMemory fetchPointer: priority - 1 ofObject: processLists.
yieldImplicitly
ifTrue: [self addLastLink: aProcess toList: processList]
ifFalse: [self addFirstLink: aProcess toList: processList]!
Item was 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!!!!"
| headerStart headerSize headerFlags dataSize oldBaseAddr swapBytes
minimumMemory bytesRead bytesToShift heapSize firstSegSize
hdrEdenBytes hdrMaxExtSemTabSize hdrNumStackPages |
<var: #f type: #sqImageFile>
<var: #heapSize type: #usqInt>
<var: #dataSize type: #'size_t'>
<var: #minimumMemory type: #usqInt>
<var: #desiredHeapSize type: #usqInt>
<var: #headerStart type: #squeakFileOffsetType>
<var: #imageOffset type: #squeakFileOffsetType>
metaclassNumSlots := 6. "guess Metaclass instSize"
classNameIndex := 6. "guess (Class instVarIndexFor: 'name' ifAbsent: []) - 1"
swapBytes := self checkImageVersionFrom: f startingAt: imageOffset.
+ headerStart := (self sqImageFilePosition: f) - objectMemory wordSize. "record header start position"
- headerStart := (self sqImageFilePosition: f) - BytesPerWord. "record header start position"
headerSize := self getLongFromFile: f swap: swapBytes.
dataSize := self getLongFromFile: f swap: swapBytes.
oldBaseAddr := self getLongFromFile: f swap: swapBytes.
objectMemory specialObjectsOop: (self getLongFromFile: f swap: swapBytes).
objectMemory lastHash: (self getLongFromFile: f swap: swapBytes). "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.
It is used for the cog code size in Cog. Preserve it to be polite to other VMs."
theUnknownShort := self getShortFromFile: f swap: swapBytes.
hdrEdenBytes := self getLongFromFile: f swap: swapBytes.
objectMemory edenBytes: (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].
"pad to word boundary. This slot can be used for anything else that will fit in 16 bits.
Preserve it to be polite to other VMs."
the2ndUnknownShort := self getShortFromFile: f swap: swapBytes.
firstSegSize := self getLongFromFile: f swap: swapBytes.
objectMemory firstSegmentSize: firstSegSize.
"decrease Squeak object heap to leave extra memory for the VM"
heapSize := desiredHeapSize
+ objectMemory newSpaceBytes
+ self interpreterAllocationReserveBytes.
heapSize := self reserveExtraCHeap: heapSize Bytes: extraVMMemory.
"compare memory requirements with availability".
minimumMemory := dataSize + objectMemory newSpaceBytes + self interpreterAllocationReserveBytes.
heapSize < minimumMemory ifTrue:
[self insufficientMemorySpecifiedError].
"allocate a contiguous block of memory for the Squeak heap"
objectMemory memory: (self
allocateMemory: heapSize
minimum: minimumMemory
imageFile: f
headerSize: headerSize) asUnsignedInteger.
objectMemory memory ifNil: [self insufficientMemoryAvailableError].
objectMemory
setHeapBase: objectMemory memory
memoryLimit: objectMemory memory + heapSize
endOfMemory: objectMemory memory + 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 := objectMemory readHeapFromImageFile: f dataBytes: dataSize.
bytesRead ~= dataSize ifTrue: [self unableToReadImageError].
self ensureImageFormatIsUpToDate: swapBytes.
"compute difference between old and new memory base addresses"
bytesToShift := objectMemory memoryBaseForImageRead - 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].
"We're about to leave this stack page; must save the current frame's instructionPointer."
self push: instructionPointer.
self externalWriteBackHeadFramePointers.
"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) + objectMemory wordSize.
- stackPointer := framePointer + (self frameStackedReceiverOffset: framePointer) + 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) - objectMemory wordSize.
- stackPointer := (self findSPOf: theFP on: thePage) - 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].
"We're about to leave this stack page; must save the current frame's instructionPointer."
self push: instructionPointer.
self externalWriteBackHeadFramePointers.
"Mark callbackMethodContext as dead; the common case is that it is the current frame.
We go the extra mile for the debugger."
(self isSingleContext: callbackMethodContext)
ifTrue: [self markContextAsDead: callbackMethodContext]
ifFalse:
[theFP := self frameOfMarriedContext: callbackMethodContext.
framePointer = theFP "common case"
ifTrue:
[(self isBaseFrame: theFP)
ifTrue: [stackPages freeStackPage: stackPage]
ifFalse: "calloutMethodContext is immediately below on the same page. Make it current."
[instructionPointer := (self frameCallerSavedIP: framePointer) asUnsignedInteger.
+ stackPointer := framePointer + (self frameStackedReceiverOffset: framePointer) + objectMemory wordSize.
- stackPointer := framePointer + (self frameStackedReceiverOffset: framePointer) + BytesPerWord.
framePointer := self frameCallerFP: framePointer.
self restoreCStackStateForCallbackContext: vmCallbackContext.
"N.B. siglongjmp is defines as _longjmp on non-win32 platforms.
This matches the use of _setjmp in ia32abicc.c."
self siglong: vmCallbackContext trampoline jmp: (self integerValueOf: returnTypeOop).
^true]]
ifFalse:
[self externalDivorceFrame: theFP andContext: callbackMethodContext.
self markContextAsDead: callbackMethodContext]].
"Make the calloutMethodContext the active frame. The case where calloutMethodContext
is immediately below callbackMethodContext on the same page is handled above."
(self isStillMarriedContext: calloutMethodContext)
ifTrue:
[theFP := self frameOfMarriedContext: calloutMethodContext.
thePage := stackPages stackPageFor: theFP.
"findSPOf:on: points to the word beneath the instructionPointer, but
there is no instructionPointer on the top frame of the current page."
self assert: thePage ~= stackPage.
+ stackPointer := (self findSPOf: theFP on: thePage) - objectMemory wordSize.
- stackPointer := (self findSPOf: theFP on: thePage) - BytesPerWord.
framePointer := theFP]
ifFalse:
[thePage := self makeBaseFrameFor: calloutMethodContext.
framePointer := thePage headFP.
stackPointer := thePage headSP].
instructionPointer := self popStack.
self setMethod: (objectMemory fetchPointer: MethodIndex ofObject: calloutMethodContext).
self setStackPageAndLimit: thePage.
self restoreCStackStateForCallbackContext: vmCallbackContext.
"N.B. siglongjmp is defines as _longjmp on non-win32 platforms.
This matches the use of _setjmp in ia32abicc.c."
self siglong: vmCallbackContext trampoline jmp: (self integerValueOf: returnTypeOop).
"NOTREACHED"
^true!
Item was 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 isImmediate: displayBits)
or: [(objectMemory isNonIntegerObject: w)
or: [objectMemory isPointersNonImm: displayBits]]) ifTrue: [^ nil].
wordStartIndex := startIndex * 4.
wordEndIndex := endIndex * 4 min: (objectMemory sizeBitsOf: displayBits).
+ displayBits := displayBits + objectMemory baseHeaderSize.
- displayBits := displayBits + BaseHeaderSize.
displayBits + wordStartIndex to: displayBits + wordEndIndex by: 4 do:
[:ptr | | reversed |
reversed := (objectMemory long32At: ptr) bitXor: 4294967295.
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>>sendInvokeCallbackContext: (in category 'callback support') -----
sendInvokeCallbackContext: vmCallbackContext
"Send the calllback message to Alien class with the supplied arg(s). Use either the
1 arg invokeCallbackContext: or the 4 arg invokeCallback:stack:registers:jmpbuf:
message, depending on what selector is installed in the specialObjectsArray.
Note that if invoking the legacy invokeCallback:stack:registers:jmpbuf: we pass the
vmCallbackContext as the jmpbuf argument (see reestablishContextPriorToCallback:).
The arguments are raw C addresses and are converted to integer objects on the way."
<export: true>
<var: #vmCallbackContext type: #'VMCallbackContext *'>
| classTag |
classTag := self fetchClassTagOfNonImm: (self splObj: ClassAlien).
messageSelector := self splObj: SelectorInvokeCallback.
(self lookupInMethodCacheSel: messageSelector classTag: classTag) ifFalse:
[(self lookupMethodNoMNUEtcInClass: (objectMemory classForClassTag: classTag)) ~= 0 ifTrue:
[^false]].
primitiveFunctionPointer ~= 0 ifTrue:
[^false].
self saveCStackStateForCallbackContext: vmCallbackContext.
self push: (self splObj: ClassAlien). "receiver"
+ self cppIf: objectMemory wordSize = 8
- self cppIf: 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>>setHeadFP:andSP:inPage: (in category 'stack pages') -----
setHeadFP: theFP andSP: theSP inPage: thePage
<inline: true>
- <asmLabel: false>
<var: #theFP type: #'char *'>
<var: #theSP type: #'char *'>
<var: #thePage type: #'StackPage *'>
self assert: theSP < theFP.
self assert: (theSP < thePage baseAddress
+ and: [theSP > (thePage realStackLimit - (LargeContextSlots * objectMemory bytesPerOop))]).
- and: [theSP > (thePage realStackLimit - LargeContextSize)]).
self assert: (theFP < thePage baseAddress
+ and: [theFP > (thePage realStackLimit - (LargeContextSlots * objectMemory bytesPerOop / 2))]).
- and: [theFP > (thePage realStackLimit - (LargeContextSize / 2))]).
thePage headFP: theFP; headSP: theSP!
Item was changed:
----- Method: StackInterpreter>>setStackPageAndLimit: (in category 'stack pages') -----
setStackPageAndLimit: thePage
"Set stackPage to a different page. Set stackLimit unless it has
been smashed. Make the stackPage the most recently used"
<inline: true>
- <asmLabel: false>
<var: #thePage type: #'StackPage *'>
self assert: thePage ~= 0.
stackPage := thePage.
stackLimit ~= (self cCoerceSimple: -1 signedIntToLong to: #'char *') ifTrue:
[stackLimit := stackPage stackLimit].
stackPages markStackPageMostRecentlyUsed: thePage!
Item was changed:
----- Method: StackInterpreter>>shuffleArgumentsAndStoreAbsentReceiver: (in category 'send bytecodes') -----
shuffleArgumentsAndStoreAbsentReceiver: theReceiver
"For the absent receiver sends move the arguments up the stack and store the supplied receiver."
<inline: true>
+ localSP := localSP - objectMemory bytesPerOop. "a.k.a. self internalPush: anything"
- localSP := localSP - BytesPerOop. "a.k.a. self internalPush: anything"
1 to: argumentCount do:
[:i| | oop |
oop := self internalStackValue: i.
self internalStackValue: i - 1 put: oop].
self internalStackValue: argumentCount put: theReceiver!
Item was changed:
----- Method: StackInterpreter>>signed64BitIntegerFor: (in category 'primitive support') -----
signed64BitIntegerFor: integerValue
<var: 'integerValue' type: #sqLong>
"Answer a Large Integer object for the given integer value. N.B. will *not* cause a GC."
| newLargeInteger magnitude largeClass highWord sz |
<inline: false>
<var: 'magnitude' type: #sqLong>
<var: 'highWord' type: #usqInt>
integerValue < 0
ifTrue:[ largeClass := ClassLargeNegativeIntegerCompactIndex.
magnitude := 0 - integerValue]
ifFalse:[ largeClass := ClassLargePositiveIntegerCompactIndex.
magnitude := integerValue].
"Make sure to handle the most -ve value correctly. 0 - most -ve = most -ve and most -ve - 1
is +ve. Alas the simple (negative or: [integerValue - 1 < 0]) fails with contemporary gcc and icc
versions with optimization and sometimes without. The shift works on all, touch wood."
(magnitude <= 16r7FFFFFFF
and: [integerValue >= 0
or: [0 ~= (self cCode: [integerValue << 1]
inSmalltalk: [integerValue << 1 bitAnd: (1 << 64) - 1])]]) ifTrue:
[^self signed32BitIntegerFor: integerValue].
highWord := magnitude >> 32.
highWord = 0
ifTrue:[sz := 4]
ifFalse:
[sz := 5.
(highWord := highWord >> 8) = 0 ifFalse:[sz := sz + 1].
(highWord := highWord >> 8) = 0 ifFalse:[sz := sz + 1].
(highWord := highWord >> 8) = 0 ifFalse:[sz := sz + 1]].
newLargeInteger := objectMemory
eeInstantiateSmallClassIndex: largeClass
format: (objectMemory byteFormatForNumBytes: sz)
+ numSlots: sz + 3 // objectMemory bytesPerOop.
- numSlots: sz + 3 // objectMemory bytesPerSlot.
sz > 4 ifTrue:
[objectMemory
storeByte: 7 ofObject: newLargeInteger withValue: (magnitude >> 56 bitAnd: 16rFF);
storeByte: 6 ofObject: newLargeInteger withValue: (magnitude >> 48 bitAnd: 16rFF);
storeByte: 5 ofObject: newLargeInteger withValue: (magnitude >> 40 bitAnd: 16rFF);
storeByte: 4 ofObject: newLargeInteger withValue: (magnitude >> 32 bitAnd: 16rFF)].
objectMemory
storeByte: 3 ofObject: newLargeInteger withValue: (magnitude >> 24 bitAnd: 16rFF);
storeByte: 2 ofObject: newLargeInteger withValue: (magnitude >> 16 bitAnd: 16rFF);
storeByte: 1 ofObject: newLargeInteger withValue: (magnitude >> 8 bitAnd: 16rFF);
storeByte: 0 ofObject: newLargeInteger withValue: (magnitude ">> 0" bitAnd: 16rFF).
^newLargeInteger!
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) - objectMemory baseHeaderSize.
- oop := (self oopForPointer: cPtr) - BaseHeaderSize.
(objectMemory isWordsOrBytes: oop) ifFalse: [
self primitiveFail.
^0].
^objectMemory lengthOf: oop
!
Item was changed:
----- Method: StackInterpreter>>slowPrimitiveResponse (in category 'primitive support') -----
slowPrimitiveResponse
"Invoke a normal (non-quick) primitive.
Called under the assumption that primFunctionPointer has been preloaded."
| nArgs savedFramePointer savedStackPointer |
<inline: true>
- <asmLabel: false>
<var: #savedFramePointer type: #'char *'>
<var: #savedStackPointer type: #'char *'>
self assert: (objectMemory isOopForwarded: (self stackValue: argumentCount)) not.
self assert: objectMemory remapBufferCount = 0.
FailImbalancedPrimitives ifTrue:
[nArgs := argumentCount.
savedStackPointer := stackPointer.
savedFramePointer := framePointer].
self initPrimCall.
self dispatchFunctionPointer: primitiveFunctionPointer.
self maybeRetryFailureDueToForwarding.
self maybeFailForLastObjectOverwrite.
(FailImbalancedPrimitives
and: [self successful
and: [framePointer = savedFramePointer
and: [(self isMachineCodeFrame: framePointer) not]]]) ifTrue:"Don't fail if primitive has done something radical, e.g. perform:"
+ [stackPointer ~= (savedStackPointer + (nArgs * objectMemory wordSize)) ifTrue:
- [stackPointer ~= (savedStackPointer + (nArgs * 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>>stackFloatValue: (in category 'stack access') -----
stackFloatValue: offset
"In the StackInterpreter stacks grow down."
<returnTypeC: #double>
+ ^self floatValueOf: (stackPages longAt: stackPointer + (offset*objectMemory wordSize))!
- ^self floatValueOf: (stackPages longAt: stackPointer + (offset*BytesPerWord))!
Item was changed:
----- Method: StackInterpreter>>stackIntegerValue: (in category 'stack access') -----
stackIntegerValue: offset
"In the StackInterpreter stacks grow down."
| integerPointer |
+ integerPointer := stackPages longAt: stackPointer + (offset*objectMemory wordSize).
- integerPointer := stackPages longAt: stackPointer + (offset*BytesPerWord).
^self checkedIntegerValueOf: integerPointer!
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) * objectMemory wordSize!
- ^(FrameSlots + 64) * BytesPerWord!
Item was changed:
----- Method: StackInterpreter>>stackObjectValue: (in category 'stack access') -----
stackObjectValue: offset
"Ensures that the given object is a real object, not a SmallInteger."
"In the StackInterpreter stacks grow down."
| oop |
+ oop := stackPages longAt: stackPointer + (offset * objectMemory wordSize).
- oop := stackPages longAt: stackPointer + (offset * BytesPerWord).
(objectMemory isImmediate: oop) ifTrue:
[self primitiveFail. ^ nil].
^oop!
Item was changed:
----- Method: StackInterpreter>>stackPointerIndexForFrame:WithSP: (in category 'frame access') -----
stackPointerIndexForFrame: theFP WithSP: theSP
"Return the 1-based index rel to the given frame"
"In the StackInterpreter stacks grow down."
+ ^(((theFP + FoxReceiver) - theSP) >> objectMemory shiftForWord) + (self frameNumArgs: theFP)!
- ^(((theFP + FoxReceiver) - theSP) >> ShiftForWord) + (self frameNumArgs: theFP)!
Item was changed:
----- Method: StackInterpreter>>stackPositiveMachineIntegerValue: (in category 'stack access') -----
stackPositiveMachineIntegerValue: offset
<api>
"In the StackInterpreter stacks grow down."
| integerPointer |
+ integerPointer := stackPages longAt: stackPointer + (offset*objectMemory wordSize).
- integerPointer := stackPages longAt: stackPointer + (offset*BytesPerWord).
^self positiveMachineIntegerValueOf: integerPointer!
Item was changed:
----- Method: StackInterpreter>>stackSignedMachineIntegerValue: (in category 'stack access') -----
stackSignedMachineIntegerValue: offset
<api>
"In the StackInterpreter stacks grow down."
| integerPointer |
+ integerPointer := stackPages longAt: stackPointer + (offset*objectMemory wordSize).
- integerPointer := stackPages longAt: stackPointer + (offset*BytesPerWord).
^self signedMachineIntegerValueOf: integerPointer!
Item was changed:
----- Method: StackInterpreter>>stackValue: (in category 'stack access') -----
stackValue: offset
<api>
"In the StackInterpreter stacks grow down."
+ ^stackPages longAt: stackPointer + (offset*objectMemory wordSize)!
- ^stackPages longAt: stackPointer + (offset*BytesPerWord)!
Item was changed:
----- Method: StackInterpreter>>stackValue:put: (in category 'stack access') -----
stackValue: offset put: oop
"In the StackInterpreter stacks grow down."
^stackPages
+ longAt: stackPointer + (offset*objectMemory wordSize)
- longAt: stackPointer + (offset*BytesPerWord)
put: oop!
Item was changed:
----- Method: StackInterpreter>>stringOf: (in category 'debug support') -----
stringOf: oop
<doNotGenerate>
| size long nLongs chars |
^ String streamContents:
[:strm |
size := 128 min: (self stSizeOf: oop).
+ nLongs := size-1//objectMemory wordSize+1.
- nLongs := size-1//BytesPerWord+1.
1 to: nLongs do:
+ [:i | long := self longAt: oop + objectMemory baseHeaderSize + (i-1*objectMemory wordSize).
- [:i | long := self longAt: oop + BaseHeaderSize + (i-1*BytesPerWord).
chars := self charsOfLong: long.
strm nextPutAll: (i=nLongs
+ ifTrue: [chars copyFrom: 1 to: size-1\\objectMemory wordSize+1]
- ifTrue: [chars copyFrom: 1 to: size-1\\BytesPerWord+1]
ifFalse: [chars])]]!
Item was changed:
----- Method: StackInterpreter>>subscript:with:format: (in category 'indexing primitive support') -----
subscript: array with: index format: fmt
"Note: This method assumes that the index is within bounds!!"
<inline: true>
- <asmLabel: false> "If labelled icc duplicates when inlining stObject:at:"
fmt <= objectMemory lastPointerFormat ifTrue:
[^objectMemory fetchPointer: index - 1 ofObject: array].
fmt >= objectMemory firstByteFormat ifTrue:
[^objectMemory integerObjectOf:
(objectMemory fetchByte: index - 1 ofObject: array)].
"long-word type objects"
^self positive32BitIntegerFor:
(objectMemory fetchLong32: index - 1 ofObject: array)!
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) * objectMemory wordSize)]
+ ifFalse: [stackPages longAt: theFP + FoxReceiver - objectMemory wordSize + ((frameNumArgs - offset) * objectMemory wordSize)]!
- ifTrue: [stackPages longAt: theFP + FoxCallerSavedIP + ((frameNumArgs - offset) * BytesPerWord)]
- ifFalse: [stackPages longAt: theFP + FoxReceiver - BytesPerWord + ((frameNumArgs - offset) * 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) * objectMemory wordSize) put: valueOop]
+ ifFalse: [stackPages longAt: theFP + FoxReceiver - objectMemory wordSize + ((frameNumArgs - offset) * objectMemory wordSize) put: valueOop]!
- ifTrue: [stackPages longAt: theFP + FoxCallerSavedIP + ((frameNumArgs - offset) * BytesPerWord) put: valueOop]
- ifFalse: [stackPages longAt: theFP + FoxReceiver - BytesPerWord + ((frameNumArgs - offset) * 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) * objectMemory wordSize)]
+ ifFalse: [theFP + FoxReceiver - objectMemory wordSize + ((numArgs - offset) * objectMemory wordSize)]!
- ifTrue: [theFP + FoxCallerSavedIP + ((numArgs - offset) * BytesPerWord)]
- ifFalse: [theFP + FoxReceiver - BytesPerWord + ((numArgs - offset) * BytesPerWord)]!
Item was changed:
----- Method: StackInterpreter>>transferTo: (in category 'process primitive support') -----
transferTo: newProc
"Record a process to be awoken on the next interpreter cycle."
| activeContext sched oldProc |
<inline: false>
statProcessSwitch := statProcessSwitch + 1.
self push: instructionPointer.
self externalWriteBackHeadFramePointers.
self assertValidExecutionPointe: instructionPointer + 1 r: framePointer s: stackPointer.
sched := self schedulerPointer.
oldProc := objectMemory fetchPointer: ActiveProcessIndex ofObject: sched.
+ activeContext := self ensureFrameIsMarried: framePointer SP: stackPointer + objectMemory wordSize.
- activeContext := self ensureFrameIsMarried: framePointer SP: stackPointer + BytesPerWord.
objectMemory storePointer: SuspendedContextIndex ofObject: oldProc withValue: activeContext.
objectMemory storePointer: ActiveProcessIndex ofObject: sched withValue: newProc.
objectMemory storePointerUnchecked: MyListIndex ofObject: newProc withValue: objectMemory nilObject.
self externalSetStackPageAndPointersForSuspendedContextOfProcess: newProc!
Item was changed:
----- Method: StackInterpreter>>unPop: (in category 'internal interpreter access') -----
unPop: nItems
"In the StackInterpreter stacks grow down."
+ stackPointer := stackPointer - (nItems*objectMemory wordSize)!
- stackPointer := stackPointer - (nItems*BytesPerWord)!
Item was changed:
----- Method: StackInterpreter>>updateObjectsPostByteSwap (in category 'image save/restore') -----
updateObjectsPostByteSwap
"Byte-swap the words of all bytes objects in 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."
| swapFloatWords |
swapFloatWords := objectMemory vmEndianness ~= imageFloatsBigEndian.
self assert: ClassFloatCompactIndex ~= 0.
objectMemory allObjectsDo:
[:oop| | fmt wordAddr methodHeader temp |
fmt := objectMemory formatOf: oop.
fmt >= self firstByteFormat ifTrue: "oop contains bytes"
+ [wordAddr := oop + objectMemory baseHeaderSize.
- [wordAddr := oop + BaseHeaderSize.
fmt >= self firstCompiledMethodFormat ifTrue: "compiled method; start after methodHeader and literals"
+ [methodHeader := self longAt: oop + objectMemory baseHeaderSize.
+ wordAddr := wordAddr + (((objectMemory literalCountOfMethodHeader: methodHeader) + LiteralStart) * objectMemory bytesPerOop)].
- [methodHeader := self longAt: oop + BaseHeaderSize.
- wordAddr := wordAddr + (((objectMemory literalCountOfMethodHeader: methodHeader) + LiteralStart) * BytesPerOop)].
objectMemory reverseBytesFrom: wordAddr to: oop + (objectMemory sizeBitsOf: oop)].
fmt = self firstLongFormat ifTrue: "Bitmap, Float etc"
[(swapFloatWords
and: [(objectMemory compactClassIndexOf: oop) = ClassFloatCompactIndex])
ifTrue:
+ [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]
- [temp := self longAt: oop + BaseHeaderSize.
- self longAt: oop + BaseHeaderSize put: (self longAt: oop + BaseHeaderSize + 4).
- self longAt: oop + BaseHeaderSize + 4 put: temp]
ifFalse:
+ [objectMemory wordSize = 8 ifTrue: "Object contains 32-bit half-words packed into 64-bit machine words."
+ [wordAddr := oop + objectMemory baseHeaderSize.
- [BytesPerWord = 8 ifTrue: "Object contains 32-bit half-words packed into 64-bit machine words."
- [wordAddr := oop + BaseHeaderSize.
objectMemory reverseWordsFrom: wordAddr to: oop + (objectMemory sizeBitsOf: 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.
"update the arguments. this would appear not to be strictly necessary, but is for two reasons.
First, the fact that arguments are read-only is only as convention in the Smalltalk compiler;
other languages may choose to modify arguments.
Second, the Squeak runUntilErrorOrReturnFrom: nightmare pops the stack top, which may, in
certain circumstances, be the last argument, and hence the last argument may not have been
stored into the context."
pointer := theFP + (self frameStackedReceiverOffsetNumArgs: tempIndex).
1 to: tempIndex do:
[:i|
+ pointer := pointer - objectMemory wordSize.
- pointer := pointer - BytesPerWord.
self assert: (objectMemory addressCouldBeOop: (stackPages longAt: pointer)).
objectMemory storePointer: ReceiverIndex + i
ofObject: theContext
withValue: (stackPages longAt: pointer)].
"now update the non-argument stack contents."
+ pointer := theFP + FoxReceiver - objectMemory wordSize.
- pointer := theFP + FoxReceiver - 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 - objectMemory wordSize].
- pointer := pointer - BytesPerWord].
self assert: ReceiverIndex + tempIndex < (objectMemory lengthOf: theContext).
objectMemory storePointerUnchecked: StackPointerIndex
ofObject: theContext
withValue: (objectMemory integerObjectOf: tempIndex)!
Item was changed:
----- Method: StackInterpreter>>withSmallIntegerTags: (in category 'frame access') -----
withSmallIntegerTags: value
<inline: true>
<var: #value type: #'char *'>
+ self assert: ((self oopForPointer: value) bitAnd: objectMemory wordSize - 1) = 0.
- self assert: ((self oopForPointer: value) bitAnd: BytesPerWord - 1) = 0.
^(self oopForPointer: value) + 1!
Item was changed:
----- Method: StackInterpreter>>wordSwapped: (in category 'image save/restore') -----
wordSwapped: w
"Return the given 64-bit integer with its halves in the reverse order."
+ objectMemory wordSize = 8 ifFalse: [self error: 'This cannot happen.'].
- BytesPerWord = 8 ifFalse: [self error: 'This cannot happen.'].
^ ((w bitShift: Byte4ShiftNegated) bitAnd: Bytes3to0Mask)
+ ((w bitShift: Byte4Shift ) bitAnd: Bytes7to4Mask)
!
Item was changed:
----- Method: StackInterpreter>>writeImageFileIOSimulation (in category 'image save/restore') -----
writeImageFileIOSimulation
"Write the image header and heap contents to imageFile for snapshot.
c.f. writeImageFileIO"
<doNotGenerate>
| headerSize file |
+ objectMemory wordSize = 4 ifFalse: [self error: 'Not rewritten for 64 bits yet'].
- BytesPerWord = 4 ifFalse: [self error: 'Not rewritten for 64 bits yet'].
headerSize := 64.
(file := FileStream fileNamed: self imageName) ifNil:
[self primitiveFail.
^nil].
[
file binary.
{
self imageFormatVersion.
headerSize.
objectMemory imageSizeToWrite.
objectMemory baseAddressOfImage.
objectMemory specialObjectsOop.
objectMemory lastHash.
self ioScreenSize.
self getImageHeaderFlags.
extraVMMemory ifNil: [0]
}
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].
objectMemory hasSpurMemoryManagerAPI
ifTrue:
[| bytesWritten |
self putLong: objectMemory firstSegmentBytes toFile: file.
self putLong: objectMemory bytesLeftInOldSpace toFile: file.
2 timesRepeat: [self putLong: 0 toFile: file "Pad the rest of the header."].
"Position the file after the header."
file position: headerSize.
bytesWritten := objectMemory writeImageSegmentsToFile: file.
self assert: bytesWritten = objectMemory imageSizeToWrite]
ifFalse:
["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 baseAddressOfImage // 4 + 1
to: objectMemory baseAddressOfImage + objectMemory imageSizeToWrite // 4
do: [:index |
self
putLong: (objectMemory memory at: index)
toFile: file]].
self success: true
]
ensure: [file ifNotNil: [file close]]!
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+objectMemory baseHeaderSize)
- instructionPointer: instructionPointer + 2 - (method+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 isArray |
<var: #addr declareC: 'void (*addr)()'>
argumentArray := self stackTop.
methodArg := self stackValue: 2.
((objectMemory isArray: argumentArray)
and: [objectMemory isOopCompiledMethod: methodArg]) ifFalse:
[^self primitiveFailFor: -2]. "invalid args"
arraySize := objectMemory numSlotsOf: argumentArray.
(self roomToPushNArgs: arraySize) ifFalse:
[^self primitiveFailFor: -2]. "invalid args"
methodHeader := objectMemory methodHeaderOf: methodArg.
(objectMemory literalCountOfMethodHeader: methodHeader) > 2 ifFalse:
[^self primitiveFailFor: -3]. "invalid methodArg state"
spec := objectMemory fetchPointer: 1 "first literal" ofObject: methodArg.
isArray := self isInstanceOfClassArray: spec.
(isArray
and: [(objectMemory lengthOf: spec) = 4
and: [(self primitiveIndexOfMethod: methodArg header: 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 + objectMemory baseHeaderSize
- addr := self ioLoadExternalFunction: functionName + BaseHeaderSize
OfLength: functionLength
+ FromModule: moduleName + objectMemory baseHeaderSize
- FromModule: moduleName + 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."
tempOop := objectMemory
eeInstantiateClassIndex: ClassArrayCompactIndex
format: objectMemory arrayFormat
numSlots: (objectMemory hasSpurMemoryManagerAPI
ifTrue: [5]
ifFalse: [4]).
objectMemory
storePointerUnchecked: 0 ofObject: tempOop withValue: (argumentArray := self popStack);
storePointerUnchecked: 1 ofObject: tempOop withValue: (primRcvr := self popStack);
storePointerUnchecked: 2 ofObject: tempOop withValue: self popStack; "the method"
storePointerUnchecked: 3 ofObject: tempOop withValue: 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)].
objectMemory hasSpurMemoryManagerAPI
ifTrue:
[objectMemory storePointerUnchecked: 4 ofObject: tempOop withValue: newMethod.
newMethod := methodArg.
self callExternalPrimitive: addr. "On Spur, sets primitiveFunctionPointer"
self maybeRetryFailureDueToForwarding.
newMethod := objectMemory fetchPointer: 4 ofObject: tempOop]
ifFalse:
[self callExternalPrimitive: addr].
self successful ifFalse: "If primitive failed, then restore state for failure code"
[self pop: arraySize + 1.
self push: (objectMemory fetchPointer: 3 ofObject: tempOop).
self push: (objectMemory fetchPointer: 2 ofObject: tempOop).
self push: (objectMemory fetchPointer: 1 ofObject: tempOop).
self push: (objectMemory fetchPointer: 0 ofObject: tempOop).
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] (or in Spur, the accessorDepth)
* 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 accessorDepth index |
<var: #addr declareC: 'void (*addr)()'>
+ "Check for it being a method for primitiveDoPrimitiveWithArgs.
+ Fetch the first literal of the method; check its an Array of length 4.
+ Look at the function index in case it has been loaded before"
+ ((objectMemory isOopCompiledMethod: newMethod)
+ and: [(objectMemory literalCountOf: newMethod) > 0
+ and: [lit := self literal: 0 ofMethod: newMethod.
+ (objectMemory isArray: lit)
+ and: [(objectMemory numSlotsOf: lit) = 4
+ and: [index := objectMemory fetchPointer: 3 ofObject: lit.
+ objectMemory isIntegerObject: index]]]]) ifFalse:
- "Fetch the first literal of the method"
- (objectMemory 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. "On Spur, sets primitiveFunctionPointer"
self maybeRetryFailureDueToForwarding.
^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.
"Spur needs to know the primitive's accessorDepth which is stored in the last slot of the first literal."
objectMemory hasSpurMemoryManagerAPI
ifTrue:
+ [addr := self ioLoadExternalFunction: functionName + objectMemory baseHeaderSize
- [addr := self ioLoadExternalFunction: functionName + BaseHeaderSize
OfLength: functionLength
+ FromModule: moduleName + objectMemory baseHeaderSize
- FromModule: moduleName + BaseHeaderSize
OfLength: moduleLength
AccessorDepthInto: (self addressOf: accessorDepth
put: [:val| accessorDepth := val]).
addr = 0
ifTrue: [index := -1]
ifFalse: "add the function to the external primitive table"
[index := self addToExternalPrimitiveTable: addr.
objectMemory
storePointerUnchecked: 2
ofObject: lit
withValue: (objectMemory integerObjectOf: accessorDepth)]]
ifFalse:
+ [addr := self ioLoadExternalFunction: functionName + objectMemory baseHeaderSize
- [addr := self ioLoadExternalFunction: functionName + BaseHeaderSize
OfLength: functionLength
+ FromModule: moduleName + objectMemory baseHeaderSize
- FromModule: moduleName + 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.
self maybeRetryFailureDueToForwarding]
ifFalse: "Otherwise void the primitive function and fail"
[self rewriteMethodCacheEntryForExternalPrimitiveToFunction: 0.
self assert: (objectMemory fetchPointer: 2 ofObject: lit) = ConstZero.
self primitiveFailFor: PrimErrNotFound]!
Item was changed:
----- Method: StackInterpreterPrimitives>>primitiveObjectPointsTo (in category 'object access primitives') -----
primitiveObjectPointsTo
"This primitive is assumed to be fast (see e.g. MethodDictionary>>includesKey:) so make it so.
N.B. Works forrectly for cogged methods too."
| rcvr thang header fmt numSlots methodHeader |
thang := self stackTop.
rcvr := self stackValue: 1.
(objectMemory isImmediate: rcvr) ifTrue:
[^self pop: 2 thenPushBool: false].
"Inlined version of lastPointerOf: for speed in determining if rcvr is a context."
header := objectMemory baseHeader: rcvr.
fmt := objectMemory formatOfHeader: header.
(objectMemory isPointersFormat: fmt)
ifTrue:
[(fmt = objectMemory indexablePointersFormat
and: [objectMemory isContextHeader: header])
ifTrue:
[(self isMarriedOrWidowedContext: rcvr) ifTrue:
[self externalWriteBackHeadFramePointers.
(self isStillMarriedContext: rcvr) ifTrue:
[^self pop: 2
thenPushBool: (self marriedContext: rcvr
pointsTo: thang
stackDeltaForCurrentFrame: 2)]].
"contexts end at the stack pointer"
numSlots := CtxtTempFrameStart + (self fetchStackPointerOf: rcvr)]
ifFalse:
[numSlots := objectMemory numSlotsOf: rcvr]]
ifFalse:
[fmt < objectMemory firstCompiledMethodFormat "no pointers" ifTrue:
[^self pop: 2 thenPushBool: false].
"CompiledMethod: contains both pointers and bytes:"
methodHeader := objectMemory methodHeaderOf: rcvr.
methodHeader = thang ifTrue: [^self pop: 2 thenPushBool: true].
numSlots := (objectMemory literalCountOfMethodHeader: methodHeader) + LiteralStart].
+ self assert: numSlots - 1 * objectMemory bytesPerOop + objectMemory baseHeaderSize = (objectMemory lastPointerOf: rcvr).
- self assert: numSlots - 1 * BytesPerOop + objectMemory baseHeaderSize = (objectMemory lastPointerOf: rcvr).
objectMemory baseHeaderSize
+ to: numSlots - 1 * objectMemory bytesPerOop + objectMemory baseHeaderSize
+ by: objectMemory bytesPerOop
- to: numSlots - 1 * BytesPerOop + objectMemory baseHeaderSize
- by: BytesPerOop
do: [:i|
(self longAt: rcvr + i) = thang ifTrue:
[^self pop: 2 thenPushBool: true]].
self pop: 2 thenPushBool: false!
Item was changed:
----- Method: StackInterpreterPrimitives>>primitivePerform (in category 'control primitives') -----
primitivePerform
<returnTypeC: #void>
| newReceiver lookupClassTag performMethod |
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 * objectMemory wordSize)
+ put: (stackPages longAt: stackPointer + ((i - 1) * objectMemory wordSize))].
- longAt: stackPointer + (i * BytesPerWord)
- put: (stackPages longAt: stackPointer + ((i - 1) * BytesPerWord))].
self pop: 1.
lookupClassTag := objectMemory fetchClassTagOf: newReceiver.
self sendBreakpoint: messageSelector receiver: newReceiver.
self printSends ifTrue:
[self printActivationNameForSelector: messageSelector
startClass: (objectMemory classForClassTag: lookupClassTag); cr].
self findNewMethodInClassTag: lookupClassTag.
"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) * objectMemory wordSize)
+ put: (stackPages longAt: stackPointer + (i * objectMemory wordSize))].
+ stackPages longAt: stackPointer + (argumentCount * objectMemory wordSize) put: messageSelector.
- stackPages longAt: stackPointer + ((i - 1) * BytesPerWord)
- put: (stackPages longAt: stackPointer + (i * BytesPerWord))].
- stackPages longAt: stackPointer + (argumentCount * BytesPerWord) put: messageSelector.
argumentCount := argumentCount + 1.
newMethod := performMethod.
^self primitiveFail].
self executeNewMethod.
"Recursive xeq affects primErrorCode"
self initPrimCall!
Item was changed:
----- Method: StackInterpreterPrimitives>>primitiveStoreStackp (in category 'object access primitives') -----
primitiveStoreStackp
"Atomic store into context stackPointer.
Also ensures that any newly accessible cells are initialized to nil "
| ctxt newStackp theFP thePage onCurrentPage stackp |
<var: #theFP type: #'char *'>
<var: #thePage type: #'StackPage *'>
ctxt := self stackValue: 1.
newStackp := self stackIntegerValue: 0.
(self successful
+ and: [newStackp between: 0 and: (objectMemory numSlotsOf: ctxt) - CtxtTempFrameStart]) ifFalse:
- and: [newStackp between: 0 and: (objectMemory lengthOf: ctxt)]) ifFalse:
[^self primitiveFail].
self externalWriteBackHeadFramePointers.
(self isStillMarriedContext: ctxt) ifTrue:
[theFP := self frameOfMarriedContext: ctxt.
thePage := stackPages stackPageFor: theFP.
((onCurrentPage := thePage = stackPage)
and: [theFP = framePointer]) ifTrue:
[^self primitiveFail]. "Probably easy to do this right here right now (just move stackPointer). But fail for now."
self externalDivorceFrame: theFP andContext: ctxt.
onCurrentPage
ifTrue:
[framePointer := stackPage headFP.
stackPointer := stackPage headSP]
ifFalse:
[self assert: stackPage = (stackPages stackPageFor: framePointer).
stackPages markStackPageMostRecentlyUsed: stackPage]].
stackp := self fetchStackPointerOf: ctxt.
"Nil any newly accessible cells"
stackp + 1 to: newStackp do:
[:i | objectMemory storePointerUnchecked: i + CtxtTempFrameStart - 1 ofObject: ctxt withValue: objectMemory nilObject].
self storeStackPointerValue: newStackp inContext: ctxt.
self ensureContextIsExecutionSafeAfterAssignToStackPointer: ctxt.
self pop: 1!
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: [objectMemory 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) asUnsignedInteger.
newSP := self frameCallerSP: frameAbove.
+ newFP := newSP - stackedReceiverOffset - objectMemory wordSize.
- newFP := newSP - stackedReceiverOffset - BytesPerWord.
theFP + stackedReceiverOffset
to: stackPointer
+ by: objectMemory wordSize negated
- by: BytesPerWord negated
do: [:source|
+ newSP := newSP - objectMemory wordSize.
- newSP := newSP - BytesPerWord.
stackPages longAt: newSP put: (stackPages longAt: source)].
stackPages longAt: newFP + FoxSavedFP put: contextsFP.
stackPages longAt: newFP + FoxCallerSavedIP put: contextsIP.
self assert: (objectMemory 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: (objectMemory 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) - objectMemory wordSize.
- [contextsSP := (self frameCallerSP: frameAbove) - 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!
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 - objectMemory baseHeaderSize)!
- Clipboard clipboardText: (self stringOf: actualDataAddress - BaseHeaderSize)!
Item was changed:
----- Method: StackInterpreterSimulator>>shortPrint: (in category 'debug support') -----
shortPrint: oop
| name classOop |
(objectMemory isImmediate: oop) ifTrue:
[(objectMemory isImmediateCharacter: oop) ifTrue:
[^(objectMemory characterValueOf: oop) < 256
ifTrue:
['=$' , (objectMemory characterValueOf: oop) printString ,
' (' , (String with: (Character value: (objectMemory characterValueOf: oop))) , ')']
ifFalse:
['=$' , (objectMemory characterValueOf: oop) printString, '(???)']].
(objectMemory isIntegerObject: oop) ifTrue:
[^ '=' , (objectMemory integerValueOf: oop) printString ,
' (' , (objectMemory integerValueOf: oop) hex , ')'].
^'= UNKNOWN IMMEDIATE', ' (' , (objectMemory integerValueOf: oop) hex , ')'].
(objectMemory addressCouldBeObj: oop) ifFalse:
[^(oop bitAnd: objectMemory allocationUnit - 1) ~= 0
ifTrue: [' is misaligned']
ifFalse: [self whereIs: oop]].
(objectMemory isFreeObject: oop) ifTrue:
[^' is a free chunk of size ', (objectMemory sizeOfFree: oop) printString].
(objectMemory isForwarded: oop) ifTrue:
[^' is a forwarded object to ', (objectMemory followForwarded: oop) hex,
' of slot size ', (objectMemory numSlotsOfAny: oop) printString].
classOop := objectMemory fetchClassOfNonImm: oop.
classOop ifNil: [^' has a nil class!!!!'].
(objectMemory numSlotsOf: classOop) = metaclassNumSlots 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: "SpurMemoryManager has immediate Characters; ObjectMemory does not"
[^ '=' , (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].
(#('Association' 'ReadOnlyVariableBinding' 'VariableBinding') includes: name) ifTrue:
[^ '(' ,
+ (self shortPrint: (self longAt: oop + objectMemory baseHeaderSize)) ,
- (self shortPrint: (self longAt: oop + BaseHeaderSize)) ,
' -> ' ,
+ (self longAt: oop + objectMemory baseHeaderSize + objectMemory wordSize) hex8 , ')'].
- (self longAt: oop + BaseHeaderSize + BytesPerWord) hex8 , ')'].
^(('AEIOU' includes: name first) ifTrue: ['an '] ifFalse: ['a ']), name!
Item was changed:
----- Method: StackInterpreterSimulator>>vmPathGet:Length: (in category 'file primitives') -----
vmPathGet: stringBase Length: stringSize
| pathName stringOop |
pathName := Smalltalk vmPath.
+ stringOop := stringBase - objectMemory baseHeaderSize. "Due to C call in Interp"
- stringOop := stringBase - 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: StackInterpreterSimulatorLSB>>nextLongFrom: (in category 'initialization') -----
nextLongFrom: aStream
"Read a 32- or 64-bit quantity from the given (binary) stream."
+ ^ aStream nextLittleEndianNumber: objectMemory wordSize!
- ^ aStream nextLittleEndianNumber: BytesPerWord!
Item was changed:
----- Method: StackToRegisterMappingCogit class>>declareCVarsIn: (in category 'translation') -----
declareCVarsIn: aCodeGen
aCodeGen
var: #methodAbortTrampolines
declareC: 'sqInt methodAbortTrampolines[4]';
var: #picAbortTrampolines
declareC: 'sqInt picAbortTrampolines[4]';
var: #picMissTrampolines
declareC: 'sqInt picMissTrampolines[4]';
var: 'ceCall0ArgsPIC'
declareC: 'void (*ceCall0ArgsPIC)(void)';
var: 'ceCall1ArgsPIC'
declareC: 'void (*ceCall1ArgsPIC)(void)';
var: 'ceCall2ArgsPIC'
declareC: 'void (*ceCall2ArgsPIC)(void)';
var: #ceCallCogCodePopReceiverArg0Regs
declareC: 'void (*ceCallCogCodePopReceiverArg0Regs)(void)';
var: #realCECallCogCodePopReceiverArg0Regs
declareC: 'void (*realCECallCogCodePopReceiverArg0Regs)(void)';
var: #ceCallCogCodePopReceiverArg1Arg0Regs
declareC: 'void (*ceCallCogCodePopReceiverArg1Arg0Regs)(void)';
var: #realCECallCogCodePopReceiverArg1Arg0Regs
declareC: 'void (*realCECallCogCodePopReceiverArg1Arg0Regs)(void)';
var: 'simStack'
+ declareC: 'CogSimStackEntry simStack[', ((CoInterpreter bindingOf: #LargeContextSlots) value * 5 // 4) asString, ']';
- declareC: 'CogSimStackEntry simStack[', ((CoInterpreter bindingOf: #LargeContextSize) value * 5 / 4 // BytesPerWord) asString, ']';
var: 'simSelf'
type: #CogSimStackEntry;
var: #optStatus
type: #CogSSOptStatus;
var: 'prevBCDescriptor'
type: #'BytecodeDescriptor *'.
self numPushNilsFunction ifNotNil:
[aCodeGen
var: 'numPushNilsFunction'
declareC: 'sqInt (* const numPushNilsFunction)(struct _BytecodeDescriptor *,sqInt,sqInt,sqInt) = ', (aCodeGen cFunctionNameFor: self numPushNilsFunction);
var: 'pushNilSizeFunction'
declareC: 'sqInt (* const pushNilSizeFunction)(sqInt) = ', (aCodeGen cFunctionNameFor: self pushNilSizeFunction)].
aCodeGen
addSelectorTranslation: #register to: (aCodeGen cFunctionNameFor: 'registerr');
addSelectorTranslation: #register: to: (aCodeGen cFunctionNameFor: 'registerr:')!
Item was changed:
----- Method: StackToRegisterMappingCogit>>compileOpenPIC:numArgs: (in category 'in-line cacheing') -----
compileOpenPIC: selector numArgs: numArgs
"Compile the code for an open PIC. Perform a probe of the first-level method
lookup cache followed by a call of ceSendFromInLineCacheMiss: if the probe fails.
Override to push the register args when calling ceSendFromInLineCacheMiss:"
| jumpSelectorMiss jumpClassMiss itsAHit jumpBCMethod |
<var: #jumpSelectorMiss type: #'AbstractInstruction *'>
<var: #jumpClassMiss type: #'AbstractInstruction *'>
<var: #itsAHit type: #'AbstractInstruction *'>
<var: #jumpBCMethod type: #'AbstractInstruction *'>
self compilePICProlog: numArgs.
self cppIf: NewspeakVM ifTrue:
[self Nop. "1st nop differentiates dynSuperEntry from no-check entry if using nextMethod"
dynSuperEntry := self Nop].
entry := objectRepresentation genGetClassTagOf: ReceiverResultReg into: ClassReg scratchReg: TempReg.
"Do first of three probes. See CoInterpreter>>lookupInMethodCacheSel:classTag:"
self flag: #lookupInMethodCacheSel:classTag:. "so this method shows up as a sender of lookupInMethodCacheSel:class:"
self MoveR: ClassReg R: SendNumArgsReg.
self annotate: (self XorCw: selector R: ClassReg) objRef: selector.
+ self LogicalShiftLeftCq: objectMemory shiftForWord R: ClassReg.
+ self AndCq: MethodCacheMask << objectMemory shiftForWord R: ClassReg.
+ self MoveMw: coInterpreter methodCacheAddress asUnsignedInteger + (MethodCacheSelector << objectMemory shiftForWord)
- self LogicalShiftLeftCq: ShiftForWord R: ClassReg.
- self AndCq: MethodCacheMask << ShiftForWord R: ClassReg.
- self MoveMw: coInterpreter methodCacheAddress asUnsignedInteger + (MethodCacheSelector << ShiftForWord)
r: ClassReg
R: TempReg.
self annotate: (self CmpCw: selector R: TempReg) objRef: selector.
jumpSelectorMiss := self JumpNonZero: 0.
+ self MoveMw: coInterpreter methodCacheAddress asUnsignedInteger + (MethodCacheClass << objectMemory shiftForWord)
- self MoveMw: coInterpreter methodCacheAddress asUnsignedInteger + (MethodCacheClass << ShiftForWord)
r: ClassReg
R: TempReg.
self CmpR: SendNumArgsReg R: TempReg.
jumpClassMiss := self JumpNonZero: 0.
itsAHit := self Label.
"Fetch the method. The interpret trampoline requires the bytecoded method in SendNumArgsReg"
+ self MoveMw: coInterpreter methodCacheAddress asUnsignedInteger + (MethodCacheMethod << objectMemory shiftForWord)
- self MoveMw: coInterpreter methodCacheAddress asUnsignedInteger + (MethodCacheMethod << ShiftForWord)
r: ClassReg
R: SendNumArgsReg.
"If the method is compiled jump to its unchecked entry-point, otherwise interpret it."
objectRepresentation
genLoadSlot: HeaderIndex sourceReg: SendNumArgsReg destReg: TempReg.
self MoveR: TempReg R: ClassReg.
jumpBCMethod := objectRepresentation genJumpSmallIntegerInScratchReg: TempReg.
jumpBCMethod jmpTarget: interpretLabel.
self AddCq: cmNoCheckEntryOffset R: ClassReg.
self JumpR: ClassReg.
"First probe missed. Do second of three probes. Shift hash right one and retry."
jumpSelectorMiss jmpTarget: (jumpClassMiss jmpTarget: self Label).
self MoveR: SendNumArgsReg R: ClassReg.
self annotate: (self XorCw: selector R: ClassReg) objRef: selector.
+ self LogicalShiftLeftCq: objectMemory shiftForWord - 1 R: ClassReg.
+ self AndCq: MethodCacheMask << objectMemory shiftForWord R: ClassReg.
+ self MoveMw: coInterpreter methodCacheAddress asUnsignedInteger + (MethodCacheSelector << objectMemory shiftForWord)
- self LogicalShiftLeftCq: ShiftForWord - 1 R: ClassReg.
- self AndCq: MethodCacheMask << ShiftForWord R: ClassReg.
- self MoveMw: coInterpreter methodCacheAddress asUnsignedInteger + (MethodCacheSelector << ShiftForWord)
r: ClassReg
R: TempReg.
self annotate: (self CmpCw: selector R: TempReg) objRef: selector.
jumpSelectorMiss := self JumpNonZero: 0.
+ self MoveMw: coInterpreter methodCacheAddress asUnsignedInteger + (MethodCacheClass << objectMemory shiftForWord)
- self MoveMw: coInterpreter methodCacheAddress asUnsignedInteger + (MethodCacheClass << ShiftForWord)
r: ClassReg
R: TempReg.
self CmpR: SendNumArgsReg R: TempReg.
self JumpZero: itsAHit.
"Second probe missed. Do last probe. Shift hash right two and retry."
jumpSelectorMiss jmpTarget: self Label.
self MoveR: SendNumArgsReg R: ClassReg.
self annotate: (self XorCw: selector R: ClassReg) objRef: selector.
+ objectMemory shiftForWord > 2 ifTrue:
+ [self LogicalShiftLeftCq: objectMemory shiftForWord - 1 R: ClassReg].
+ self AndCq: MethodCacheMask << objectMemory shiftForWord R: ClassReg.
+ self MoveMw: coInterpreter methodCacheAddress asUnsignedInteger + (MethodCacheSelector << objectMemory shiftForWord)
- ShiftForWord > 2 ifTrue:
- [self LogicalShiftLeftCq: ShiftForWord - 1 R: ClassReg].
- self AndCq: MethodCacheMask << ShiftForWord R: ClassReg.
- self MoveMw: coInterpreter methodCacheAddress asUnsignedInteger + (MethodCacheSelector << ShiftForWord)
r: ClassReg
R: TempReg.
self annotate: (self CmpCw: selector R: TempReg) objRef: selector.
jumpSelectorMiss := self JumpNonZero: 0.
+ self MoveMw: coInterpreter methodCacheAddress asUnsignedInteger + (MethodCacheClass << objectMemory shiftForWord)
- self MoveMw: coInterpreter methodCacheAddress asUnsignedInteger + (MethodCacheClass << ShiftForWord)
r: ClassReg
R: TempReg.
self CmpR: SendNumArgsReg R: TempReg.
self JumpZero: itsAHit.
"Last probe missed. Call ceSendFromInLineCacheMiss: to do the full lookup."
jumpSelectorMiss jmpTarget: self Label.
backEnd genPushRegisterArgsForNumArgs: numArgs.
self genSmalltalkToCStackSwitch.
methodLabel addDependent: (self annotateAbsolutePCRef: (self MoveCw: methodLabel asInteger R: SendNumArgsReg)).
self
compileCallFor: #ceSendFromInLineCacheMiss:
numArgs: 1
arg: SendNumArgsReg
arg: nil
arg: nil
arg: nil
resultReg: nil
saveRegs: false
"Note that this call does not return."!
Item was added:
+ ----- Method: StackToRegisterMappingCogit>>declareCVarsIn: (in category 'as yet unclassified') -----
+ declareCVarsIn: aCodeGen
+ aCodeGen
+ var: #methodAbortTrampolines
+ declareC: 'sqInt methodAbortTrampolines[4]';
+ var: #picAbortTrampolines
+ declareC: 'sqInt picAbortTrampolines[4]';
+ var: #picMissTrampolines
+ declareC: 'sqInt picMissTrampolines[4]';
+ var: 'ceCall0ArgsPIC'
+ declareC: 'void (*ceCall0ArgsPIC)(void)';
+ var: 'ceCall1ArgsPIC'
+ declareC: 'void (*ceCall1ArgsPIC)(void)';
+ var: 'ceCall2ArgsPIC'
+ declareC: 'void (*ceCall2ArgsPIC)(void)';
+ var: #ceCallCogCodePopReceiverArg0Regs
+ declareC: 'void (*ceCallCogCodePopReceiverArg0Regs)(void)';
+ var: #realCECallCogCodePopReceiverArg0Regs
+ declareC: 'void (*realCECallCogCodePopReceiverArg0Regs)(void)';
+ var: #ceCallCogCodePopReceiverArg1Arg0Regs
+ declareC: 'void (*ceCallCogCodePopReceiverArg1Arg0Regs)(void)';
+ var: #realCECallCogCodePopReceiverArg1Arg0Regs
+ declareC: 'void (*realCECallCogCodePopReceiverArg1Arg0Regs)(void)';
+ var: 'simStack'
+ declareC: 'CogSimStackEntry simStack[', ((CoInterpreter bindingOf: #LargeContextSize) value * 5 / 4 // objectMemory wordSize) asString, ']';
+ var: 'simSelf'
+ type: #CogSimStackEntry;
+ var: #optStatus
+ type: #CogSSOptStatus;
+ var: 'prevBCDescriptor'
+ type: #'BytecodeDescriptor *'.
+
+ self numPushNilsFunction ifNotNil:
+ [aCodeGen
+ var: 'numPushNilsFunction'
+ declareC: 'sqInt (* const numPushNilsFunction)(struct _BytecodeDescriptor *,sqInt,sqInt,sqInt) = ', (aCodeGen cFunctionNameFor: self numPushNilsFunction);
+ var: 'pushNilSizeFunction'
+ declareC: 'sqInt (* const pushNilSizeFunction)(sqInt) = ', (aCodeGen cFunctionNameFor: self pushNilSizeFunction)].
+
+ aCodeGen
+ addSelectorTranslation: #register to: (aCodeGen cFunctionNameFor: 'registerr');
+ addSelectorTranslation: #register: to: (aCodeGen cFunctionNameFor: 'registerr:')!
Item was changed:
----- Method: StackToRegisterMappingCogit>>genPopStackBytecode (in category 'bytecode generators') -----
genPopStackBytecode
self annotateBytecodeIfAnnotated: self ssTop.
self ssTop spilled ifTrue:
+ [self AddCq: objectMemory wordSize R: SPReg].
- [self AddCq: BytesPerWord R: SPReg].
self ssPop: 1.
^0!
Item was changed:
----- Method: StackToRegisterMappingCogit>>genPrimitiveClass (in category 'primitive generators') -----
genPrimitiveClass
"Depending on argument count the argument is either
0 args: ReceiverResultReg
1 args: Arg0Reg
N args: top of stack (assuming 1 reg arg for now)"
| reg |
methodOrBlockNumArgs = 1
ifTrue:
[reg := Arg0Reg]
ifFalse:
[methodOrBlockNumArgs > 0 ifTrue:
+ [self MoveMw: objectMemory wordSize r: SPReg R: ReceiverResultReg].
- [self MoveMw: BytesPerWord r: SPReg R: ReceiverResultReg].
reg := ReceiverResultReg].
(objectRepresentation
genGetClassObjectOf: reg
into: ReceiverResultReg
scratchReg: TempReg
instRegIsReceiver: methodOrBlockNumArgs = 0) = BadRegisterSet ifTrue:
[objectRepresentation
genGetClassObjectOf: reg
into: ClassReg
scratchReg: TempReg
instRegIsReceiver: methodOrBlockNumArgs = 0.
self MoveR: ClassReg R: ReceiverResultReg].
self RetN: 0.
^0!
Item was changed:
----- Method: StackToRegisterMappingCogit>>genUpArrowReturn (in category 'bytecode generators') -----
genUpArrowReturn
"Generate a method return from within a method or a block.
Frameless method activation looks like
receiver
args
sp-> ret pc.
Return pops receiver and arguments off the stack. Callee pushes the result."
inBlock ifTrue:
[self assert: needsFrame.
self annotateBytecode: (self CallRT: ceNonLocalReturnTrampoline).
^0].
needsFrame
ifTrue:
[self MoveR: FPReg R: SPReg.
self PopR: FPReg.
backEnd hasLinkRegister ifTrue:
[self PopR: LinkReg].
+ self RetN: methodOrBlockNumArgs + 1 * objectMemory wordSize]
- self RetN: methodOrBlockNumArgs + 1 * BytesPerWord]
ifFalse:
[backEnd hasLinkRegister ifTrue:
[self PopR: LinkReg].
self RetN: ((methodOrBlockNumArgs > self numRegArgs
"A method with an interpreter prim will push its register args for the prim. If the failure
body is frameless the args must still be popped, see e.g. Behavior>>nextInstance."
or: [regArgsHaveBeenPushed])
+ ifTrue: [methodOrBlockNumArgs + 1 * objectMemory wordSize]
- ifTrue: [methodOrBlockNumArgs + 1 * BytesPerWord]
ifFalse: [0])].
^0!
Item was changed:
----- Method: StackToRegisterMappingCogit>>initSimStackForFramefulMethod: (in category 'simulation stack') -----
initSimStackForFramefulMethod: startpc
<var: #desc type: #'CogSimStackEntry *'>
optStatus isReceiverResultRegLive: false.
simSelf
type: SSBaseOffset;
spilled: true;
annotateUse: false;
register: FPReg;
offset: FoxMFReceiver.
simSpillBase := methodOrBlockNumTemps. "N.B. Includes num args"
simStackPtr := simSpillBase - 1.
"args"
0 to: methodOrBlockNumArgs - 1 do:
[:i| | desc |
desc := self simStackAt: i.
desc
type: SSBaseOffset;
spilled: true;
annotateUse: false;
register: FPReg;
+ offset: FoxCallerSavedIP + ((methodOrBlockNumArgs - i) * objectMemory wordSize);
- offset: FoxCallerSavedIP + ((methodOrBlockNumArgs - i) * BytesPerWord);
bcptr: startpc].
"temps"
methodOrBlockNumArgs to: simStackPtr do:
[:i| | desc |
desc := self simStackAt: i.
desc
type: SSBaseOffset;
spilled: true;
annotateUse: false;
register: FPReg;
+ offset: FoxMFReceiver - (i - methodOrBlockNumArgs + 1 * objectMemory wordSize);
- offset: FoxMFReceiver - (i - methodOrBlockNumArgs + 1 * BytesPerWord);
bcptr: startpc]!
Item was changed:
----- Method: StackToRegisterMappingCogit>>initSimStackForFramelessBlock: (in category 'simulation stack') -----
initSimStackForFramelessBlock: startpc
"The register receiver (the closure itself) and args are pushed by the closure value primitive(s)
and hence a frameless block has all arguments and copied values pushed to the stack. However,
the method receiver (self) is put in the ReceiverResultRegister by the block entry."
| desc |
<var: #desc type: #'CogSimStackEntry *'>
simSelf
type: SSRegister;
spilled: false;
annotateUse: false;
register: ReceiverResultReg.
optStatus
isReceiverResultRegLive: true;
ssEntry: (self addressOf: simSelf).
self assert: methodOrBlockNumTemps >= methodOrBlockNumArgs.
0 to: methodOrBlockNumTemps - 1 do:
[:i|
desc := self simStackAt: i.
desc
type: SSBaseOffset;
spilled: true;
annotateUse: false;
register: SPReg;
+ offset: ((methodOrBlockNumTemps - i) * objectMemory wordSize);
- offset: ((methodOrBlockNumTemps - i) * BytesPerWord);
bcptr: startpc].
simSpillBase := simStackPtr := methodOrBlockNumTemps - 1!
Item was changed:
----- Method: StackToRegisterMappingCogit>>initSimStackForFramelessMethod: (in category 'simulation stack') -----
initSimStackForFramelessMethod: startpc
| desc |
<var: #desc type: #'CogSimStackEntry *'>
simSelf
type: SSRegister;
spilled: false;
annotateUse: false;
register: ReceiverResultReg.
optStatus
isReceiverResultRegLive: true;
ssEntry: (self addressOf: simSelf).
self assert: methodOrBlockNumTemps >= methodOrBlockNumArgs.
self assert: self numRegArgs <= 2.
(methodOrBlockNumArgs between: 1 and: self numRegArgs)
ifTrue:
[desc := self simStackAt: 0.
desc
type: SSRegister;
spilled: false;
annotateUse: false;
register: Arg0Reg;
bcptr: startpc.
methodOrBlockNumArgs > 1 ifTrue:
[desc := self simStackAt: 1.
desc
type: SSRegister;
spilled: false;
annotateUse: false;
register: Arg1Reg;
bcptr: startpc]]
ifFalse:
[0 to: methodOrBlockNumArgs - 1 do:
[:i|
desc := self simStackAt: i.
desc
type: SSBaseOffset;
register: SPReg;
spilled: true;
annotateUse: false;
+ offset: ((methodOrBlockNumArgs - i) * objectMemory wordSize);
- offset: ((methodOrBlockNumArgs - i) * BytesPerWord);
bcptr: startpc]].
simSpillBase := simStackPtr := methodOrBlockNumArgs - 1!
Item was changed:
----- Method: StackToRegisterMappingCogit>>marshallImplicitReceiverSendArguments: (in category 'simulation stack') -----
marshallImplicitReceiverSendArguments: numArgs
"Spill everything on the simulated stack that needs spilling (that below arguments).
Marshall arguments to stack and/or registers depending on arg count.
If the args don't fit in registers push receiver and args (spill everything). Assume
receiver already in ResultReceiverReg so shuffle args and push it if necessary."
self ssFlushTo: simStackPtr - numArgs.
numArgs > self numRegArgs
ifTrue:
["The arguments must be pushed to the stack, and hence the receiver
must be inserted beneath the args. Reduce or eliminate the argument
shuffle by only moving already spilled items."
| numSpilled |
numSpilled := self numberOfSpillsInTopNItems: numArgs.
numSpilled > 0
ifTrue:
[self MoveMw: 0 r: SPReg R: TempReg.
self PushR: TempReg.
2 to: numSpilled do:
[:index|
+ self MoveMw: index * objectMemory wordSize r: SPReg R: TempReg.
+ self MoveR: TempReg Mw: index - 1 * objectMemory wordSize r: SPReg].
+ self MoveR: ReceiverResultReg Mw: numSpilled * objectMemory wordSize r: SPReg]
- self MoveMw: index * BytesPerWord r: SPReg R: TempReg.
- self MoveR: TempReg Mw: index - 1 * BytesPerWord r: SPReg].
- self MoveR: ReceiverResultReg Mw: numSpilled * BytesPerWord r: SPReg]
ifFalse:
[self PushR: ReceiverResultReg].
self ssFlushTo: simStackPtr]
"Move the args to the register arguments, being careful to do
so last to first so e.g. previous contents don't get overwritten.
Also check for any arg registers in use by other args."
ifFalse:
[numArgs > 0 ifTrue:
[(self numRegArgs > 1 and: [numArgs > 1])
ifTrue:
[self ssAllocateRequiredReg: Arg0Reg upThrough: simStackPtr - 2.
self ssAllocateRequiredReg: Arg1Reg upThrough: simStackPtr - 1]
ifFalse:
[self ssAllocateRequiredReg: Arg0Reg upThrough: simStackPtr - 1]].
(self numRegArgs > 1 and: [numArgs > 1]) ifTrue:
[(self simStackAt: simStackPtr) popToReg: Arg1Reg].
numArgs > 0 ifTrue:
[(self simStackAt: simStackPtr - numArgs + 1)
popToReg: Arg0Reg]].
self ssPop: numArgs!
Item was changed:
----- Method: StackToRegisterMappingCogit>>merge:afterContinuation: (in category 'simulation stack') -----
merge: fixup afterContinuation: mergeWithContinuation
"Merge control flow at a fixup. The fixup holds the simStackPtr at the jump to this target.
See stackToRegisterMapping on the class side for a full description."
<var: #fixup type: #'BytecodeFixup *'>
self traceMerge: fixup.
"For now we don't try and preserve the optimization status through merges."
optStatus isReceiverResultRegLive: false.
"If this instruction follows a return or an unconditional branch then the
current simStackPtr is irrelevant and we continue with that of the fixup."
mergeWithContinuation ifFalse:
[self assert: fixup targetInstruction asUnsignedInteger >= 2. "Must have a valid simStackPtr"
simStackPtr := fixup simStackPtr].
fixup targetInstruction asUnsignedInteger <= 2 ifTrue:
["This is either a forward or backward branch target.
The stack must be flushed."
self ssFlushTo: simStackPtr.
fixup simStackPtr <= -2 ifTrue:
"This is the target of a backward branch. It doesn't have a simStackPtr yet."
[fixup simStackPtr: simStackPtr].
fixup targetInstruction: self Label].
self assert: simStackPtr >= fixup simStackPtr.
self cCode: '' inSmalltalk:
[self assert: fixup simStackPtr = (self debugStackPointerFor: bytecodePC)].
simStackPtr := fixup simStackPtr.
simSpillBase := methodOrBlockNumTemps.
"For now throw away all type information for values on the stack, but sometime consider
the more sophisticated merge described in the class side stackToRegisterMapping."
methodOrBlockNumTemps to: simStackPtr do:
[:i|
(self simStackAt: i)
+ mergeAt: FoxMFReceiver - (i - methodOrBlockNumArgs + 1 * objectMemory bytesPerOop)
- mergeAt: FoxMFReceiver - (i - methodOrBlockNumArgs + 1 * BytesPerOop)
from: FPReg]!
Item was changed:
Object subclass: #TMethod
+ instanceVariableNames: 'selector returnType args locals declarations primitive parseTree labels writtenToGlobalVarsCache complete export static inline sharedLabel sharedCase comment definingClass globalStructureBuildMethodHasFoo properties extraVariableNumber'
- instanceVariableNames: 'selector returnType args locals declarations primitive parseTree labels writtenToGlobalVarsCache complete export static inline sharedLabel sharedCase comment definingClass globalStructureBuildMethodHasFoo canAsmLabel mustAsmLabel properties extraVariableNumber'
classVariableNames: 'CaseStatements'
poolDictionaries: ''
category: 'VMMaker-Translation to C'!
Item was removed:
- ----- Method: TMethod>>argAssignmentsFor:args:in: (in category 'inlining') -----
- argAssignmentsFor: meth args: argList in: aCodeGen
- "Return a collection of assignment nodes that assign the given argument expressions to the formal parameter variables of the given method."
- "Optimization: If the actual parameters are either constants or local variables in the target method (the receiver), substitute them directly into the body of meth. Note that global variables cannot be subsituted because the inlined method might depend on the exact ordering of side effects to the globals."
-
- | stmtList substitutionDict |
- stmtList := OrderedCollection new: 100.
- substitutionDict := Dictionary new: 100.
- meth args with: argList do:
- [ :argName :exprNode |
- (self isNode: exprNode substitutableFor: argName inMethod: meth in: aCodeGen)
- ifTrue:
- [substitutionDict at: argName put: exprNode.
- locals remove: argName]
- ifFalse:
- [stmtList add: (TAssignmentNode new
- setVariable: (TVariableNode new setName: argName)
- expression: exprNode copy)]].
- meth parseTree: (meth parseTree bindVariablesIn: substitutionDict).
- ^stmtList!
Item was removed:
- ----- Method: TMethod>>asmLabel (in category 'accessing') -----
- asmLabel
- ^canAsmLabel!
Item was removed:
- ----- Method: TMethod>>asmLabel: (in category 'accessing') -----
- asmLabel: aBoolean
- canAsmLabel := aBoolean!
Item was removed:
- ----- Method: TMethod>>extractLabelDirective (in category 'transformations') -----
- extractLabelDirective
- "Scan the top-level statements for an inlining directive of the form:
-
- self asmLabel: <boolean>
-
- and remove the directive from the method body. Answer the
- argument of the directive or true if there is no export directive."
-
- ^self
- extractDirective: #asmLabel:
- valueBlock: [:sendNode| sendNode args first value ~= false and: [mustAsmLabel := true. true]]
- default: true!
Item was changed:
----- Method: TMethod>>inlineSend:directReturn:exitVar:in: (in category 'inlining') -----
inlineSend: aSendNode directReturn: directReturn exitVar: exitVar in: aCodeGen
"Answer a collection of statements to replace the given send. directReturn indicates
that the send is the expression in a return statement, so returns can be left in the
body of the inlined method. If exitVar is nil, the value returned by the send is not
used; thus, returns need not assign to the output variable.
Types are propagated to as-yet-untyped variables when inlining a send that is assigned,
otherwise the assignee variable type must match the return type of the inlinee. Return
types are not propagated."
| sel meth methArgs exitLabel inlineStmts label exitType |
sel := aSendNode selector.
meth := aCodeGen methodNamed: sel.
methArgs := meth args.
"convenient for debugging..."
self maybeBreakFor: aSendNode in: aCodeGen.
(methArgs notEmpty and: [methArgs first beginsWith: 'self_in_']) ifTrue:
[methArgs := methArgs allButFirst].
methArgs size = aSendNode args size ifFalse:
[^nil].
methArgs with: aSendNode args do:
[:formal :actual|
(actual isVariable
and: [(aCodeGen
variableOfType: (self typeFor: formal using: aCodeGen)
acceptsValueOfType: (self typeFor: actual name in: aCodeGen)) not]) ifTrue:
[aCodeGen logger
nextPutAll:
'type mismatch for formal ', formal, ' and actual ', actual name,
' when inlining ', sel, ' in ', selector, '. Use a cast.';
cr; flush]].
meth := meth copy.
"Propagate the return type of an inlined method"
(directReturn or:[exitVar notNil]) ifTrue:[
exitType := directReturn
ifTrue:[returnType]
ifFalse:[(self typeFor: exitVar in: aCodeGen) ifNil:[#sqInt]].
(exitType = #void or:[exitType = meth returnType])
ifFalse:[meth propagateReturnIn: aCodeGen]].
meth renameVarsForInliningInto: self except: #() in: aCodeGen.
meth renameLabelsForInliningInto: self.
self addVarsDeclarationsAndLabelsOf: meth except: #().
meth hasReturn ifTrue:[
directReturn ifFalse:[
exitLabel := self unusedLabelForInliningInto: self.
(meth exitVar: exitVar label: exitLabel) "is label used?"
ifTrue: [ labels add: exitLabel ]
ifFalse: [ exitLabel := nil ]]].
(inlineStmts := OrderedCollection new: 100)
add: (label := TLabeledCommentNode new setComment: 'begin ', sel);
addAll: (self argAssignmentsFor: meth send: aSendNode in: aCodeGen);
addAll: meth statements. "method body"
- "Vile hacks to prevent too many labels. If the C compiler inlines functions it can duplicate
- labels and cause compilation to fail. The second statement prevents us creating labels in
- anything other than the interpreter. If we add labels to small functions that may be inlined
- by the C compiler then the label can be duplicated by the C compiler and cause the assembler
- to fail. eem 9/20/2008 12:29"
- (aCodeGen wantsLabels
- and: [meth asmLabel
- and: [meth mustAsmLabel or: [meth hasMoreSendsThan: 20]]]) ifTrue:
- [label asmLabel: sel].
(directReturn
and: [meth endsWithReturn not]) ifTrue:
[inlineStmts add:
(TReturnNode new setExpression: (TVariableNode new setName: 'nil'))].
exitLabel ~= nil ifTrue:
[inlineStmts add:
(TLabeledCommentNode new setLabel:
exitLabel comment: 'end ', meth selector)].
^inlineStmts!
Item was changed:
----- Method: TMethod>>isNode:substitutableFor:inMethod:in: (in category 'inlining') -----
isNode: aNode substitutableFor: argName inMethod: targetMeth in: aCodeGen
+ "Answer if the given parameter node may be substituted directly into the body of
+ the method during inlining, instead of being bound to the actual parameter variable.
+ We allow a constant, a local variable, or a formal parameter, or simple expressions
+ involving only these to to be directly substituted. Note that global variables cannot
+ be subsituted into methods with possible side effects (i.e., methods that may assign
+ to global variables) because the inlined method might depend on having the value of
+ the global variable captured when it is passed in as an argument."
- "Answer true if the given parameter node is either a constant, a local variable, or a formal parameter of the receiver. Such parameter nodes may be substituted directly into the body of the method during inlining. Note that global variables cannot be subsituted into methods with possible side effects (i.e., methods that may assign to global variables) because the inlined method might depend on having the value of the global variable captured when it is passed in as an argument."
+ | madeNonTrivialCall count constantExpression usageCount |
- | var madeNonTrivialCall |
aNode isConstant ifTrue: [^true].
aNode isVariable ifTrue:
+ [((locals includes: aNode name)
+ or: [(args includes: aNode name)
+ or: [#('self' 'true' 'false' 'nil') includes: aNode name]]) ifTrue: [^true].
- [var := aNode name.
- ((locals includes: var) or: [args includes: var]) ifTrue: [^true].
- (#(self true false nil) includes: var) ifTrue: [^true].
"We can substitute any variable provided it is only read in the method being inlined,
and if it is not read after any non-trivial call (which may update the variable)."
madeNonTrivialCall := false.
(targetMeth isComplete
and: [targetMeth parseTree
noneSatisfy:
[:node|
(node isSend
and: [(aCodeGen isBuiltinSelector: node selector) not]) ifTrue:
[madeNonTrivialCall := true].
(madeNonTrivialCall and: [node isVariable and: [node name = argName]])
or: [node isAssignment
and: [node variable name = argName]]]
unless:
[:node|
node isSend and: [aCodeGen isAssertSelector: node selector]]]) ifTrue:
[^true].
+ ^targetMeth maySubstituteGlobal: aNode name in: aCodeGen].
- (targetMeth maySubstituteGlobal: var in: aCodeGen) ifTrue: [^true]].
"For now allow literal blocks to be substituted. They better be accessed only
with value[:value:*] messages though!!"
aNode isStmtList ifTrue: [^true].
+ count := 0.
+ constantExpression := true.
"scan expression tree; must contain only constants, builtin ops, and inlineable vars"
+ aNode nodesDo:
+ [:node|
+ node isConstant
+ ifTrue: [] ifFalse:
+ [node isSend
+ ifTrue:
+ [node isBuiltinOperator ifFalse: [^false].
+ count := count + 1] ifFalse:
+ [node isVariable ifTrue:
+ [constantExpression := false.
+ ((locals includes: node name) or:
+ [(args includes: node name) or:
+ [(#('self' 'true' 'false' 'nil') includes: node name) or:
+ [targetMeth maySubstituteGlobal: node name in: aCodeGen]]]) ifFalse: [^false]] ifFalse:
+ [^false]]]].
+ "inline constant expressions"
+ constantExpression ifNil: [^true].
- aNode nodesDo: [ :node |
- node isSend ifTrue: [
- node isBuiltinOperator ifFalse: [^false].
- ].
- node isVariable ifTrue: [
- var := node name.
- ((locals includes: var) or:
- [(args includes: var) or:
- [(#(self true false nil) includes: var) or:
- [targetMeth maySubstituteGlobal: var in: aCodeGen]]]) ifFalse: [^false].
- ].
- (node isConstant or: [node isVariable or: [node isSend]]) ifFalse: [^false].
- ].
+ "scan target to find usage count"
+ usageCount := 0.
+ targetMeth parseTree nodesDo:
+ [:node|
+ (node isVariable and: [node name = argName]) ifTrue:
+ [usageCount := usageCount + 1]].
+ "Now only inline expressions if they are used only once or are simple
+ w.r.t. the usage count; a heuristic that seems to work well enough."
+ ^usageCount = 1 or: [count <= usageCount]!
- ^ true!
Item was removed:
- ----- Method: TMethod>>mustAsmLabel (in category 'accessing') -----
- mustAsmLabel
- ^mustAsmLabel == true!
Item was removed:
- ----- Method: TMethod>>mustAsmLabel: (in category 'accessing') -----
- mustAsmLabel: aBoolean
- mustAsmLabel := aBoolean!
Item was changed:
----- Method: TMethod>>setSelector:definingClass:args:locals:block:primitive:properties:comment: (in category 'initialization') -----
setSelector: sel definingClass: class args: argList locals: localList block: aBlockNode primitive: aNumber properties: methodProperties comment: aComment
"Initialize this method using the given information."
selector := sel.
definingClass := class.
args := argList asOrderedCollection collect: [:arg | arg key].
locals := (localList collect: [:arg | arg key]) asSet.
declarations := Dictionary new.
self addTypeForSelf.
primitive := aNumber.
properties := methodProperties.
comment := aComment.
parseTree := aBlockNode. "hack; allows nodes to find their parent, etc"
parseTree := aBlockNode asTranslatorNodeIn: self.
labels := Set new.
complete := false. "set to true when all possible inlining has been done"
export := self extractExportDirective.
static := self extractStaticDirective.
- canAsmLabel := self extractLabelDirective.
self extractSharedCase.
globalStructureBuildMethodHasFoo := false!
Item was added:
+ ----- Method: TParseNode>>occurrencesOf: (in category 'enumerating') -----
+ occurrencesOf: aNode
+ | count |
+ count := 0.
+ self nodesDo:
+ [:node|
+ node = aNode ifTrue: [count := count + 1]].
+ ^count!
Item was changed:
----- Method: ThreadedFFIPlugin>>sizeField: (in category 'primitive support') -----
sizeField: oop
"Answer the first field of oop which is assumed to be an Alien of at least 8 bytes"
<inline: true>
+ ^self longAt: oop + interpreterProxy baseHeaderSize!
- ^self longAt: oop + BaseHeaderSize!
Item was changed:
----- Method: ThreadedFFIPlugin>>startOfData: (in category 'primitive support') -----
startOfData: oop "<Alien oop> ^<Integer>"
"Answer the start of oop's data. For direct aliens this is the address of
the second field. For indirect and pointer aliens it is what the second field points to."
<inline: true>
^(self sizeField: oop) > 0
+ ifTrue: [oop + interpreterProxy baseHeaderSize + interpreterProxy bytesPerOop]
+ ifFalse: [self longAt: oop + interpreterProxy baseHeaderSize + interpreterProxy bytesPerOop]!
- ifTrue: [oop + BaseHeaderSize + BytesPerOop]
- ifFalse: [self longAt: oop + BaseHeaderSize + BytesPerOop]!
Item was changed:
SharedPool subclass: #VMBasicConstants
instanceVariableNames: ''
+ classVariableNames: 'BaseHeaderSize Byte0Mask Byte0Shift Byte1Mask Byte1Shift Byte1ShiftNegated Byte2Mask Byte2Shift Byte3Mask Byte3Shift Byte3ShiftNegated Byte4Mask Byte4Shift Byte4ShiftNegated Byte5Mask Byte5Shift Byte5ShiftNegated Byte6Mask Byte6Shift Byte7Mask Byte7Shift Byte7ShiftNegated Bytes3to0Mask Bytes7to4Mask BytesPerOop BytesPerWord COGMTVM COGVM DisownVMLockOutFullGC DoAssertionChecks DoExpensiveAssertionChecks GCModeBecome GCModeFull GCModeIncr GCModeScavenge IMMUTABILITY MULTIPLEBYTECODESETS NewspeakVM PrimErrBadArgument PrimErrBadIndex PrimErrBadMethod PrimErrBadNumArgs PrimErrBadReceiver PrimErrGenericFailure PrimErrInappropriate PrimErrLimitExceeded PrimErrNamedInternal PrimErrNoCMemory PrimErrNoMemory PrimErrNoModification PrimErrNotFound PrimErrObjectIsPinned PrimErrObjectMayMove PrimErrUnsupported PrimErrWritePastObject PrimNoErr STACKVM SistaVM VMBIGENDIAN'
- classVariableNames: 'BaseHeaderSize Byte0Mask Byte0Shift Byte1Mask Byte1Shift Byte1ShiftNegated Byte2Mask Byte2Shift Byte3Mask Byte3Shift Byte3ShiftNegated Byte4Mask Byte4Shift Byte4ShiftNegated Byte5Mask Byte5Shift Byte5ShiftNegated Byte6Mask Byte6Shift Byte7Mask Byte7Shift Byte7ShiftNegated Bytes3to0Mask Bytes7to4Mask BytesPerOop BytesPerWord COGMTVM COGVM DisownVMLockOutFullGC DoAssertionChecks DoExpensiveAssertionChecks GCModeBecome GCModeFull GCModeIncr GCModeScavenge IMMUTABILITY MULTIPLEBYTECODESETS NewspeakVM PrimErrBadArgument PrimErrBadIndex PrimErrBadMethod PrimErrBadNumArgs PrimErrBadReceiver PrimErrGenericFailure PrimErrInappropriate PrimErrLimitExceeded PrimErrNamedInternal PrimErrNoCMemory PrimErrNoMemory PrimErrNoModification PrimErrNotFound PrimErrObjectIsPinned PrimErrObjectMayMove PrimErrUnsupported PrimErrWritePastObject PrimNoErr STACKVM ShiftForWord SistaVM VMBIGENDIAN'
poolDictionaries: ''
category: 'VMMaker-Interpreter'!
!VMBasicConstants commentStamp: '<historical>' prior: 0!
I am a shared pool for basic constants upon which the VM as a whole depends.
self ensureClassPool.
self classPool declare: #BytesPerWord from: VMSqueakV3ObjectRepresentationConstants classPool.
self classPool declare: #BaseHeaderSize from: VMSqueakV3ObjectRepresentationConstants classPool
(ObjectMemory classPool keys select: [:k| k beginsWith: 'Byte']) do:
[:k| self classPool declare: k from: ObjectMemory classPool]!
Item was removed:
- ----- Method: VMClass>>asmLabel: (in category 'translation support') -----
- asmLabel: aBoolean
- "For translation only; noop when running in Smalltalk."!
Item was removed:
- ----- Method: VMClass>>bytesPerOop (in category 'accessing') -----
- bytesPerOop
- ^BytesPerOop!
Item was changed:
----- Method: VMClass>>cCode: (in category 'translation support') -----
cCode: codeString
"Support for Smalltalk-to-C translation.
For translation only; noop when running in Smalltalk.
+ The argument is output literally when generating C code."
+ <doNotGenerate>!
- The argument is output literally when generating C code."!
Item was changed:
----- Method: VMClass>>cCode:inSmalltalk: (in category 'translation support') -----
cCode: codeStringOrBlock inSmalltalk: aBlock
"Support for Smalltalk-to-C translation. The first argument is output when generating C code.
But if this code is being simulated in Smalltalk, answer the result of evaluating the given block.
If the first argument is a string it is output literally, and if it is a block it is translated.
N.B. If the first argument is a block then replacement happens at TMethod creation time so the use
of cCode:inSmalltalk: with a block first argument does not prevent inlining and is hence preferred."
+ <doNotGenerate>
-
^aBlock value!
Item was changed:
----- Method: VMClass>>cPreprocessorDirective: (in category 'translation support') -----
cPreprocessorDirective: codeString
+ "For translation only; noop when running in Smalltalk."
+ <doNotGenerate>!
- "For translation only; noop when running in Smalltalk."!
Item was changed:
----- Method: VMClass>>cppIf:ifTrue: (in category 'translation support') -----
cppIf: conditionBlockOrValue ifTrue: trueExpressionOrBlock
"When translated, produces #if (condition) #else #endif CPP directives.
Example usage:
self cppIf: IMMUTABILITY
ifTrue: [(self internalIsImmutable: obj) ifTrue:
[^self primitiveFailFor: PrimErrNoModification]]"
+ <doNotGenerate>
^self cppIf: conditionBlockOrValue ifTrue: trueExpressionOrBlock ifFalse: nil!
Item was changed:
----- Method: VMClass>>cppIf:ifTrue:ifFalse: (in category 'translation support') -----
cppIf: conditionBlockOrSymbolValue ifTrue: trueExpressionOrBlock ifFalse: falseExpressionOrBlockOrNil
"When translated, produces #if (condition) #else #endif CPP directives.
Example usage:
self cppIf: [BytesPerWord = 8]
ifTrue: [self doSomethingFor64Bit]
ifFalse: [self doSomethingFor32Bit]
self cppIf: BytesPerWord = 8
ifTrue: [self doSomethingFor64Bit]
ifFalse: [self doSomethingFor32Bit]
self cppIf: #A_GLOBAL
ifTrue: [self doSomethingFor64Bit]
ifFalse: [self doSomethingFor32Bit]"
+ <doNotGenerate>
^(conditionBlockOrSymbolValue value
ifNil: [false]
ifNotNil: [:value|
value isInteger
ifTrue: [value ~= 0]
ifFalse:
[value isSymbol
ifTrue: [(self class bindingOf: value)
ifNil: [false]
ifNotNil: [:binding| binding value]]
ifFalse: [value]]])
ifTrue: trueExpressionOrBlock
ifFalse: falseExpressionOrBlockOrNil!
Item was removed:
- ----- Method: VMClass>>sharedCodeNamed:inCase: (in category 'translation support') -----
- sharedCodeNamed: label inCase: caseNumber
- "For translation only; noop when running in Smalltalk."!
Item was changed:
----- Method: VMClass>>sizeof: (in category 'translation support') -----
sizeof: objectSymbolOrClass
<doNotGenerate>
| index |
objectSymbolOrClass isInteger ifTrue:
+ [^self class objectMemoryClass wordSize].
- [self flag: #Dan.
- ^BytesPerWord].
objectSymbolOrClass isSymbol ifTrue:
[(objectSymbolOrClass last == $*
or: [#long == objectSymbolOrClass
or: [#'unsigned long' == objectSymbolOrClass]]) ifTrue:
+ [^self class objectMemoryClass wordSize].
- [^BytesPerWord].
index := #( #sqLong #usqLong #double
#int #'unsigned int' #float
#short #'unsigned short'
#char #'unsigned char' #'signed char')
indexOf: objectSymbolOrClass
ifAbsent:
+ [objectSymbolOrClass = #sqInt ifTrue: [^self class objectMemoryClass bytesPerOop].
- [objectSymbolOrClass = #sqInt ifTrue: [^BytesPerOop].
self error: 'unrecognized C type name'].
^#(8 8 8
4 4 4
2 2
1 1 1) at: index].
^(objectSymbolOrClass isBehavior
ifTrue: [objectSymbolOrClass]
ifFalse: [objectSymbolOrClass class])
alignedByteSizeOf: objectSymbolOrClass
forClient: self!
Item was changed:
----- Method: VMMaker>>generateCogitFile (in category 'generate sources') -----
generateCogitFile
"Translate the Smalltalk description of the virtual machine into C. If 'self doInlining' is true, small method bodies are inlined to reduce procedure call overhead. On the PPC, this results in a factor of three speedup with only 30% increase in code size. Subclasses can use specialised versions of CCodeGenerator and interpreterClass."
| cg cogitClass |
(cogitClass := self interpreterClass cogitClass) ifNil: [^nil].
cg := [self buildCodeGeneratorForCogit]
on: Notification
do: [:ex|
ex tag == #getVMMaker
ifTrue: [ex resume: self]
ifFalse: [(ex respondsTo: #rearmHandlerDuring:)
ifTrue: [ex rearmHandlerDuring: [ex pass]]
ifFalse: [ex pass]]].
self needsToRegenerateCogitFile ifFalse: [^nil].
- cg removeUnneededBuiltins.
cg inferTypesForImplicitlyTypedVariablesAndMethods.
cg vmClass preGenerationHook: cg.
cg storeCodeOnFile: (self sourceFilePathFor: cogitClass sourceFileName) doInlining: cogitClass doInlining.
cg vmClass additionalHeadersDo:
[:headerName :headerContents| | filePath |
filePath := self coreVMDirectory fullNameFor: headerName.
(cg needToGenerateHeader: headerName file: filePath contents: headerContents) ifTrue:
[cg storeHeaderOnFile: filePath contents: headerContents]].
cogitClass apiExportHeaderName ifNotNil:
[cg storeAPIExportHeader: cogitClass apiExportHeaderName
OnFile: (self sourceFilePathFor: cogitClass apiExportHeaderName)]!
Item was changed:
----- Method: VMMaker>>generateInterpreterFile (in category 'generate sources') -----
generateInterpreterFile
"Translate the Smalltalk description of the virtual machine into C. If 'self doInlining' is true, small method bodies are inlined to reduce procedure call overhead. On the PPC, this results in a factor of three speedup with only 30% increase in code size. Subclasses can use specialised versions of CCodeGenerator and interpreterClass."
| cg vmHeaderContents |
cg := [self buildCodeGeneratorForInterpreter]
on: Notification
do: [:ex|
ex tag == #getVMMaker
ifTrue: [ex resume: self]
ifFalse: [(ex respondsTo: #rearmHandlerDuring:)
ifTrue: [ex rearmHandlerDuring: [ex pass]]
ifFalse: [ex pass]]].
self needsToRegenerateInterpreterFile ifFalse: [^nil].
- cg removeUnneededBuiltins.
cg inferTypesForImplicitlyTypedVariablesAndMethods.
self interpreterClass preGenerationHook: cg.
vmHeaderContents := cg vmHeaderContentsWithBytesPerWord: self wordSize.
(cg needToGenerateHeader: self interpreterHeaderName file: self interpreterHeaderPath contents: vmHeaderContents) ifTrue:
[cg storeHeaderOnFile: self interpreterHeaderPath contents: vmHeaderContents].
cg storeCodeOnFile: (self sourceFilePathFor: self interpreterClass sourceFileName) doInlining: self doInlining.
self interpreterClass additionalHeadersDo:
[:headerName :headerContents| | filePath |
filePath := self coreVMDirectory fullNameFor: headerName.
(cg needToGenerateHeader: headerName file: filePath contents: headerContents) ifTrue:
[cg storeHeaderOnFile: filePath contents: headerContents]].
self interpreterClass apiExportHeaderName ifNotNil:
[cg storeAPIExportHeader: self interpreterClass apiExportHeaderName
OnFile: (self sourceFilePathFor: self interpreterClass apiExportHeaderName)].
self gnuifyInterpreterFile!
1
0
Hi Chris,
On Thu, Nov 13, 2014 at 12:24 PM, Chris Muller <ma.chris.m(a)gmail.com> wrote:
> Hi Eliot and all, while moving some serialized objects from a Cog
> image into a Spur image, I am encountered an issue materializaing a
> CompiledMethod instance in the target Spur image due to the new
> implementation of #numLiterals. In Cog it's:
>
> numLiterals
> "Answer the number of literals used by the receiver."
> | header |
> ^(header := self header) < 0
> ifTrue: [header bitAnd: 65535]
> ifFalse: [(header bitShift: -9) bitAnd: 16rFF]
>
> but in Spur, only the negative header condition is present:
>
> numLiterals
> "Answer the number of literals used by the receiver."
> ^self header bitAnd: 65535
>
Right.
The header was positive in the source Cog image, in fact, there are NO
> instances of CM's with negative headers in either my Cog or Spur
> images. So after constructing the CompiledMethod for materialization
> within the Spur image with the same #header it had in Cog, it reports
> the wrong #numLiterals and can't finish the materialization because of
> that.
>
Right.
I'm able to force a correct materialization by changing the place
> where I access "numLiterals" to the original True condition of Cog --
> "(header bitShift: -9) bitAnd: 16rFF".
>
Good. That is the "right thing to do" (tm). Or rather it is the right
thing to do when trying to import methods from Cog to Spur.
But that's just "making it work" and not understanding the
> implications of what I'm doing. I know Spur can allow more literals
> per CM, but assuming I'm willing to stay with a max of just 255
> literals for now, is my override above the best way to handle this
> need to be able to transfer objects back-and-forth within a
> heterogeneous environment of Cog and Spur images?
>
Yes, as long as it is on;y used for porting. You obviously /don'/ need it
when materializing in Spur methods that have been dematerialized in Spur
(BTW, I like the "official" terms, "pickled" and "unpickled").
Thanks for any advice and insight..
>
So the new format was introduced to lift the limit on the number of
literals. I first implemented it for Newspeak a couple of years ago for
Cadence. At this point it used the sign bit to allow both the old and new
header formats to coexist:
numLiterals
"Answer the number of literals used by the receiver."
| header |
^(header := self header) < 0
ifTrue: [header bitAnd: 65535]
ifFalse: [(header bitShift: -9) bitAnd: 16rFF]
The problems with this are
- that sign bit allows choosing between bytecode sets, and so it couples
bytecode set choice with literal limit, and
- there is a cost, at least in code density, even if not necessarily much
in performance, in the VM using the "mixed" format.
I realised in late summer with Spur that I had a chance of eliminating the
coupling and performance issues by insisting on the one format in Spur. So
I decided to eliminate the old format and just go with the simple format
(this taken from CompiledMethod's class comment in its Spur version):
The header is a 31-bit signed integer (a SmallInteger) in the following
format:
(index 0) 16 bits: number of literals (#numLiterals)
(index 16) 1 bit: has primitive
(index 17) 1 bit: whether a large frame size is needed (#frameSize =>
either SmallFrame or LargeFrame)
(index 18) 6 bits: number of temporary variables (#numTemps)
(index 24) 4 bits: number of arguments to the method (#numArgs)
(index 28) 2 bits: reserved for an access modifier (00-unused, 01-private,
10-protected, 11-public), although accessors for bit 29 exist (see #flag).
(index 30/63) sign bit: 1 selects the Secondary instruction set (e.g.
NewsqueakV4, 0 selects the primary instruction set, e.g.
SqueakV3PlusClosures) (#signFlag)
This a) makes the VM slimmer and b) makes it much less complicated to use
the two bytecode sets. The ability to use two bytecode sets provides a
smoother transition to Sista when it arrives next year.
--
best,
Eliot
1
0
Hi All.
I am done with my FileMaker gig and will be delving back into the cmake stuff tomorrow.
Is the project still wanted?
Cordially,
tty
2
2
[commit][3130] Merge Levente' s recent changes to DNS lookup on Windows and SSL on Unix.
by commitsï¼ squeakvm.org 12 Nov '14
by commitsï¼ squeakvm.org 12 Nov '14
12 Nov '14
Revision: 3130
Author: eliot
Date: 2014-11-12 11:52:35 -0800 (Wed, 12 Nov 2014)
Log Message:
-----------
Merge Levente's recent changes to DNS lookup on Windows and SSL on Unix.
See http://squeakvm.org/cgi-bin/viewvc.cgi/squeak?view=revision&revision=2249
http://bugs.squeak.org/view.php?id=7824
Modified Paths:
--------------
branches/Cog/platforms/unix/plugins/SqueakSSL/sqUnixOpenSSL.c
branches/Cog/platforms/win32/vm/sqWin32Exports.c
Added Paths:
-----------
branches/Cog/platforms/win32/vm/sqWin32DnsInfo.c
Property Changed:
----------------
branches/Cog/platforms/Cross/vm/sqSCCSVersion.h
Property changes on: branches/Cog/platforms/Cross/vm/sqSCCSVersion.h
___________________________________________________________________
Modified: checkindate
- Mon Nov 10 10:34:43 PST 2014
+ Wed Nov 12 11:52:26 PST 2014
Modified: branches/Cog/platforms/unix/plugins/SqueakSSL/sqUnixOpenSSL.c
===================================================================
--- branches/Cog/platforms/unix/plugins/SqueakSSL/sqUnixOpenSSL.c 2014-11-10 18:34:19 UTC (rev 3129)
+++ branches/Cog/platforms/unix/plugins/SqueakSSL/sqUnixOpenSSL.c 2014-11-12 19:52:35 UTC (rev 3130)
@@ -11,6 +11,7 @@
char *certName;
char *peerName;
+ char *serverName;
SSL_METHOD *method;
SSL_CTX *ctx;
@@ -135,6 +136,7 @@
if(ssl->certName) free(ssl->certName);
if(ssl->peerName) free(ssl->peerName);
+ if(ssl->serverName) free(ssl->serverName);
free(ssl);
handleBuf[handle] = NULL;
@@ -184,6 +186,13 @@
if(ssl->loglevel) printf("sqConnectSSL: BIO_write failed\n");
return SQSSL_GENERIC_ERROR;
}
+
+ /* if a server name is provided, use it */
+ if(ssl->serverName) {
+ if(ssl->loglevel) printf("sqSetupSSL: Using server name %s\n", ssl->serverName);
+ SSL_set_tlsext_host_name(ssl->ssl, ssl->serverName);
+ }
+
if(ssl->loglevel) printf("sqConnectSSL: SSL_connect\n");
result = SSL_connect(ssl->ssl);
if(result <= 0) {
@@ -370,6 +379,7 @@
switch(propID) {
case SQSSL_PROP_PEERNAME: return ssl->peerName;
case SQSSL_PROP_CERTNAME: return ssl->certName;
+ case SQSSL_PROP_SERVERNAME: return ssl->serverName;
default:
if(ssl->loglevel) printf("sqGetStringPropertySSL: Unknown property ID %d\n", propID);
return NULL;
@@ -392,14 +402,22 @@
if(ssl == NULL) return 0;
if(propLen) {
- property = calloc(1, propLen+1);
- memcpy(property, propName, propLen);
+ property = malloc(propLen + 1);
+ memcpy(property, propName, propLen);
+ property[propLen] = '\0';
};
if(ssl->loglevel) printf("sqSetStringPropertySSL(%d): %s\n", propID, property);
switch(propID) {
- case SQSSL_PROP_CERTNAME: ssl->certName = property; break;
+ case SQSSL_PROP_CERTNAME:
+ if (ssl->certName) free(ssl->certName);
+ ssl->certName = property;
+ break;
+ case SQSSL_PROP_SERVERNAME:
+ if (ssl->serverName) free(ssl->serverName);
+ ssl->serverName = property;
+ break;
default:
if(property) free(property);
if(ssl->loglevel) printf("sqSetStringPropertySSL: Unknown property ID %d\n", propID);
Copied: branches/Cog/platforms/win32/vm/sqWin32DnsInfo.c (from rev 3129, trunk/platforms/win32/vm/sqWin32DnsInfo.c)
===================================================================
--- branches/Cog/platforms/win32/vm/sqWin32DnsInfo.c (rev 0)
+++ branches/Cog/platforms/win32/vm/sqWin32DnsInfo.c 2014-11-12 19:52:35 UTC (rev 3130)
@@ -0,0 +1,180 @@
+/* sqWin32DnsInfo.c: Gathers DNS information on Windows */
+#include <windows.h>
+#include "sq.h"
+
+extern struct VirtualMachine *interpreterProxy;
+#define vm interpreterProxy
+
+/* Large enough since we only use 3 entries with 1k bytes max */
+static char buf[20000];
+
+static char* lookup(HKEY hk, char *key) {
+ static char buf[1000];
+ DWORD dwLength, ret;
+ dwLength = sizeof(buf)-1;
+ *buf = 0;
+ ret = RegQueryValueEx(hk, key, NULL, NULL, buf, &dwLength);
+ if(buf[dwLength]) buf[dwLength] = 0;
+ return buf;
+}
+
+/* Print base registry info. Return true if DNS info was provided. */
+static int printBaseInfo(char *hkeyName) {
+ HKEY hkey;
+ DWORD ret;
+ char *value;
+ int result = 0;
+
+ ret = RegOpenKeyEx(HKEY_LOCAL_MACHINE, hkeyName, 0, KEY_READ, &hkey);
+ if(ret != ERROR_SUCCESS) {
+ printf("RegOpenKeyEx failed\n");
+ return vm->primitiveFail();
+ }
+
+ /* Provide Hostname info if present */
+ value = lookup(hkey, "Hostname");
+ if(*value) {
+ strcat(buf, "\nhostname ");
+ strcat(buf, value);
+ }
+
+ /* The list of suffixes to search */
+ value = lookup(hkey, "SearchList");
+ if(*value) {
+ strcat(buf, "\nsearch ");
+ strcat(buf, value);
+ }
+
+ /* The (static or dhcp) domain */
+ value = lookup(hkey, "Domain");
+ if(*value) {
+ strcat(buf, "\ndomain ");
+ strcat(buf, value);
+ strcat(buf, " # static");
+ } else {
+ value = lookup(hkey, "DhcpDomain");
+ if(*value) {
+ strcat(buf, "\ndomain ");
+ strcat(buf, value);
+ strcat(buf, " # dhcp");
+ }
+ }
+
+ /* And the (static or dhcp) configured name servers */
+ value = lookup(hkey, "NameServer");
+ if(*value) {
+ strcat(buf, "\nnameserver ");
+ strcat(buf, value);
+ strcat(buf, " # static");
+ result = 1;
+ } else {
+ value = lookup(hkey, "DhcpNameServer");
+ if(*value) {
+ strcat(buf, "\nnameserver ");
+ strcat(buf, value);
+ strcat(buf, " # dhcp");
+ result = 1;
+ }
+ }
+ RegCloseKey(hkey);
+ return result;
+}
+
+static int printAdapterInfo(char *hkeyName) {
+ HKEY hkey;
+ DWORD ret;
+ char *value;
+ int result = 0;
+
+ ret = RegOpenKeyEx(HKEY_LOCAL_MACHINE, hkeyName, 0, KEY_READ, &hkey);
+ if(ret != ERROR_SUCCESS) {
+ printf("RegOpenKeyEx failed\n");
+ return vm->primitiveFail();
+ }
+
+ /* Provide interface address if present */
+ value = lookup(hkey, "IPAddress");
+ if(*value && strcmp(value, "0.0.0.0")) {
+ /* Skip interface info since we can't currently determine
+ if the information is correct or a dead adapter */
+#if 0
+ strcat(buf, "\ninterface ");
+ strcat(buf, value);
+ strcat(buf, " # static");
+#endif
+ } else {
+ value = lookup(hkey, "DhcpIPAddress");
+ if(*value && strcmp(value, "0.0.0.0")) {
+#if 0
+ strcat(buf, "\ninterface ");
+ strcat(buf, value);
+ strcat(buf, " # dhcp ");
+#endif
+ } else {
+ /* Don't bother printing DNS for an adapter w/o IP */
+ goto done;
+ }
+ }
+
+ /* Print the (static or dhcp) configured name servers */
+ value = lookup(hkey, "NameServer");
+ if(*value) {
+ strcat(buf, "\nnameserver ");
+ strcat(buf, value);
+ strcat(buf, " # static");
+ result = 1;
+ } else {
+ value = lookup(hkey, "DhcpNameServer");
+ if(*value) {
+ strcat(buf, "\nnameserver ");
+ strcat(buf, value);
+ strcat(buf, " # dhcp");
+ result = 1;
+ }
+ }
+
+ done:
+ RegCloseKey(hkey);
+ return result;
+}
+
+#define BASE_KEY \
+ "SYSTEM\\CurrentControlSet\\services\\Tcpip\\Parameters\\Interfaces"
+
+EXPORT(int) primitiveDnsInfo(void) {
+ HKEY hkey;
+ sqInt sz, stroop;
+ DWORD dwLength, ret, index;
+ char adapter[1024];
+
+ *buf = 0;
+ strcat(buf, "# Global config settings");
+
+ /* Print the global options */
+ if(printBaseInfo("SYSTEM\\CurrentControlSet\\services\\Tcpip\\Parameters")) {
+ /* If we have DNS entries globally, skip enumerating all interfaces */
+ goto done;
+ }
+
+ /* Enumerate the available interfaces */
+ ret = RegOpenKeyEx(HKEY_LOCAL_MACHINE, BASE_KEY, 0, KEY_READ, &hkey);
+ for(index=0;;index++) {
+ char keyName[1024];
+ dwLength = sizeof(adapter);
+ ret = RegEnumKeyEx(hkey, index, adapter, &dwLength, NULL, NULL, NULL, NULL);
+ if(ret != ERROR_SUCCESS) break;
+ strcpy(keyName, BASE_KEY);
+ strcat(keyName, "\\");
+ strcat(keyName, adapter);
+ /* Should look up and print the adapter name */
+ printAdapterInfo(keyName);
+ }
+
+ done:
+ sz = strlen(buf);
+ stroop = vm->instantiateClassindexableSize(vm->classString(), sz);
+ if(!vm->failed()) {
+ memcpy(vm->firstIndexableField(stroop), buf, sz);
+ vm->popthenPush(vm->methodArgumentCount()+1, stroop);
+ }
+}
Modified: branches/Cog/platforms/win32/vm/sqWin32Exports.c
===================================================================
--- branches/Cog/platforms/win32/vm/sqWin32Exports.c 2014-11-10 18:34:19 UTC (rev 3129)
+++ branches/Cog/platforms/win32/vm/sqWin32Exports.c 2014-11-12 19:52:35 UTC (rev 3130)
@@ -15,6 +15,7 @@
int primitivePluginRequestFileHandle(void);
int primitivePluginDestroyRequest(void);
int primitivePluginRequestState(void);
+int primitiveDnsInfo(void);
extern void* stWindow;
extern void* firstMessageHook;
@@ -36,6 +37,7 @@
{"","primitivePluginRequestFileHandle", primitivePluginRequestFileHandle},
{"","primitivePluginDestroyRequest", primitivePluginDestroyRequest},
{"","primitivePluginRequestState", primitivePluginRequestState},
+ {"","primitiveDnsInfo", primitiveDnsInfo},
{"","printf", printf},
{"","stWindow", &stWindow},
{"","firstMessageHook", &firstMessageHook},
1
0
Esteban Lorenzano uploaded a new version of Cog to project VM Maker:
http://source.squeak.org/VMMaker/Cog.pharo-EstebanLorenzano.221.mcz
==================== Summary ====================
Name: Cog.pharo-EstebanLorenzano.221
Author: EstebanLorenzano
Time: 12 November 2014, 2:21:45.767004 pm
UUID: 59c525b1-1452-41a2-ad4f-7d495b3a410d
Ancestors: Cog-EstebanLorenzano.220
empty log message
=============== Diff against Cog-eem.212 ===============
Item was changed:
+ SystemOrganization addCategory: #Cog!
+ SystemOrganization addCategory: 'Cog-Bootstrapping'!
+ SystemOrganization addCategory: 'Cog-Morphing Bytecode Set'!
+ SystemOrganization addCategory: 'Cog-ProcessorPlugins'!
+ SystemOrganization addCategory: 'Cog-Processors'!
+ SystemOrganization addCategory: 'Cog-Processors-Tests'!
+ SystemOrganization addCategory: 'Cog-Scripting'!
+ SystemOrganization addCategory: 'Cog-Scripts'!
+ SystemOrganization addCategory: 'Cog-Tests'!
- SystemOrganization addCategory: #'Cog-Bootstrapping'!
- SystemOrganization addCategory: #'Cog-Morphing Bytecode Set'!
- SystemOrganization addCategory: #'Cog-ProcessorPlugins'!
- SystemOrganization addCategory: #'Cog-Processors'!
- SystemOrganization addCategory: #'Cog-Processors-Tests'!
- SystemOrganization addCategory: #'Cog-Scripting'!
- SystemOrganization addCategory: #'Cog-Scripts'!
- SystemOrganization addCategory: #'Cog-Tests'!
Item was changed:
----- Method: Behavior>>BehaviorPROTOTYPEinstSize (in category '*Cog-method prototypes') -----
BehaviorPROTOTYPEinstSize
"Answer the number of named instance variables
(as opposed to indexed variables) of the receiver.
Above Cog Spur the class format is
<5 bits inst spec><16 bits inst size>"
^format bitAnd: 16rFFFF!
Item was changed:
----- Method: Behavior>>BehaviorPROTOTYPEinstSpec (in category '*Cog-method prototypes') -----
BehaviorPROTOTYPEinstSpec
"Answer the instance specification part of the format that defines what kind of object
an instance of the receiver is. The formats are
0 = 0 sized objects (UndefinedObject True False et al)
1 = non-indexable objects with inst vars (Point et al)
2 = indexable objects with no inst vars (Array et al)
3 = indexable objects with inst vars (MethodContext AdditionalMethodState et al)
4 = weak indexable objects with inst vars (WeakArray et al)
5 = weak non-indexable objects with inst vars (ephemerons) (Ephemeron)
6 = unused
7 = immediates (SmallInteger, Character)
8 = unused
9 = 64-bit indexable
10-11 = 32-bit indexable (Bitmap)
12-15 = 16-bit indexable
16-23 = 8-bit indexable
24-31 = compiled methods (CompiledMethod)"
^(format bitShift: -16) bitAnd: 16r1F!
Item was changed:
----- Method: BlockClosure>>BlockClosurePROTOTYPEsimulateValueWithArguments:caller: (in category '*Cog-method prototypes') -----
BlockClosurePROTOTYPEsimulateValueWithArguments: anArray caller: aContext
"Simulate the valueWithArguments: primitive. Fail if anArray is not an array of the right arity."
| newContext sz |
+ newContext := (Context newForMethod: outerContext method)
- newContext := (MethodContext newForMethod: outerContext method)
setSender: aContext
receiver: outerContext receiver
method: outerContext method
closure: self
startpc: startpc.
((newContext objectClass: anArray) ~~ Array
or: [numArgs ~= anArray size]) ifTrue:
+ [^Context primitiveFailTokenFor: nil].
- [^ContextPart primitiveFailTokenFor: nil].
sz := self basicSize.
newContext stackp: sz + numArgs.
1 to: numArgs do:
[:i| newContext at: i put: (anArray at: i)].
1 to: sz do:
[:i| newContext at: i + numArgs put: (self at: i)].
^newContext!
Item was changed:
----- Method: CompiledMethod class>>CompiledMethodclassPROTOTYPEinitialize (in category '*Cog-method prototypes') -----
CompiledMethodclassPROTOTYPEinitialize "CompiledMethod initialize"
"Initialize class variables specifying the size of the temporary frame
needed to run instances of me."
SmallFrame := 16. "Context range for temps+stack"
LargeFrame := 56.
PrimaryBytecodeSetEncoderClass ifNil:
[PrimaryBytecodeSetEncoderClass := EncoderForV3PlusClosures].
SecondaryBytecodeSetEncoderClass ifNil:
[SecondaryBytecodeSetEncoderClass := EncoderForV3PlusClosures]!
Item was changed:
----- Method: CompiledMethod class>>CompiledMethodclassPROTOTYPEinstallPrimaryBytecodeSet: (in category '*Cog-method prototypes') -----
CompiledMethodclassPROTOTYPEinstallPrimaryBytecodeSet: aBytecodeEncoderSubclass
PrimaryBytecodeSetEncoderClass == aBytecodeEncoderSubclass ifTrue:
[^self].
(aBytecodeEncoderSubclass inheritsFrom: BytecodeEncoder) ifFalse:
[self error: 'A bytecode set encoder is expected to be a subclass of BytecodeEncoder'].
(self allSubInstances
detect: [:m| m header >= 0 and: [m encoderClass ~~ aBytecodeEncoderSubclass]]
ifNone: []) ifNotNil:
[Warning signal: 'There are existing CompiledMethods with a different encoderClass.'].
PrimaryBytecodeSetEncoderClass := aBytecodeEncoderSubclass!
Item was changed:
----- Method: CompiledMethod>>CompiledMethodPROTOTYPEencoderClass (in category '*Cog-method prototypes') -----
CompiledMethodPROTOTYPEencoderClass
"Answer the encoder class that encoded the bytecodes in this method.
The sign flag bit is used by the VM to select a bytecode set. This formulation
may seem odd but this has to be fast, so no property probe unless needed."
^self header >= 0
ifTrue:
[PrimaryBytecodeSetEncoderClass]
ifFalse:
[PrimaryBytecodeSetEncoderClass == SecondaryBytecodeSetEncoderClass
ifTrue: "Support for testing prior to installing another set"
[(self propertyValueAt: #encoderClass) ifNil: [SecondaryBytecodeSetEncoderClass]]
ifFalse:
[SecondaryBytecodeSetEncoderClass]]!
Item was added:
+ ----- Method: Context>>ContextPROTOTYPEobjectClass: (in category '*Cog-method prototypes') -----
+ ContextPROTOTYPEobjectClass: aReceiver
+ <primitive: 111>
+ self primitiveFailed!
Item was added:
+ ----- Method: Context>>xray (in category '*Cog-Tests-xrays') -----
+ xray
+ "Lift the veil from a context and answer an integer describing its interior state.
+ Used for e.g. VM tests so they can verify they're testing what they think they're testing.
+ 0 implies a vanilla heap context.
+ Bit 0 = is or was married to a frame
+ Bit 1 = is still married to a frame
+ Bit 2 = frame is executing machine code
+ Bit 3 = has machine code pc (as opposed to nil or a bytecode pc)
+ Bit 4 = method is currently compiled to machine code"
+ <primitive: 213>
+ ^0 "Can only fail if unimplemented; therefore simply answer 0"!
Item was added:
+ ----- Method: Context>>xrayIsDivorced (in category '*Cog-Tests-xrays') -----
+ xrayIsDivorced
+ ^(self xray bitAnd: 3) = 1!
Item was added:
+ ----- Method: Context>>xrayIsExecutingMachineCode (in category '*Cog-Tests-xrays') -----
+ xrayIsExecutingMachineCode
+ ^self xray anyMask: 4!
Item was added:
+ ----- Method: Context>>xrayIsMarried (in category '*Cog-Tests-xrays') -----
+ xrayIsMarried
+ ^self xray anyMask: 2!
Item was added:
+ ----- Method: Context>>xrayLastExecutedMachineCode (in category '*Cog-Tests-xrays') -----
+ xrayLastExecutedMachineCode
+ ^self xray anyMask: 8!
Item was added:
+ ----- Method: Context>>xrayMethodIsCompiledToMachineCode (in category '*Cog-Tests-xrays') -----
+ xrayMethodIsCompiledToMachineCode
+ ^self xray anyMask: 16!
Item was removed:
- ----- Method: ContextPart>>ContextPartPROTOTYPEdoPrimitive:method:receiver:args: (in category '*Cog-method prototypes') -----
- ContextPartPROTOTYPEdoPrimitive: primitiveIndex method: meth receiver: receiver args: arguments
- "Simulate a primitive method whose index is primitiveIndex. The simulated receiver and
- arguments are given as arguments to this message. If successful, push result and return
- resuming context, else ^ {errCode, PrimitiveFailToken}. Any primitive which provokes
- execution needs to be intercepted and simulated to avoid execution running away."
-
- | value |
- "Judicious use of primitive 19 (a null primitive that doesn't do anything) prevents
- the debugger from entering various run-away activities such as spawning a new
- process, etc. Injudicious use results in the debugger not being able to debug
- interesting code, such as the debugger itself. hence use primitive 19 with care :-)"
- "SystemNavigation new browseAllSelect: [:m| m primitive = 19]"
- primitiveIndex = 19 ifTrue:
- [ToolSet
- debugContext: self
- label:'Code simulation error'
- contents: nil].
-
- ((primitiveIndex between: 201 and: 222)
- and: [(self objectClass: receiver) includesBehavior: BlockClosure]) ifTrue:
- [((primitiveIndex between: 201 and: 205) "BlockClosure>>value[:value:...]"
- or: [primitiveIndex between: 221 and: 222]) ifTrue: "BlockClosure>>valueNoContextSwitch[:]"
- [^receiver simulateValueWithArguments: arguments caller: self].
- primitiveIndex = 206 ifTrue: "BlockClosure>>valueWithArguments:"
- [^receiver simulateValueWithArguments: arguments first caller: self]].
-
- primitiveIndex = 83 ifTrue: "afr 9/11/1998 19:50" "Object>>perform:[with:...]"
- [^self send: arguments first to: receiver with: arguments allButFirst super: false].
- primitiveIndex = 84 ifTrue: "afr 9/11/1998 19:50 & eem 8/18/2009 17:04" "Object>>perform:withArguments:"
- [^self send: arguments first to: receiver with: (arguments at: 2) lookupIn: (self objectClass: receiver)].
- primitiveIndex = 100 ifTrue: "eem 8/18/2009 16:57" "Object>>perform:withArguments:inSuperclass:"
- [^self send: arguments first to: receiver with: (arguments at: 2) lookupIn: (arguments at: 3)].
-
- "Mutex>>primitiveEnterCriticalSection
- Mutex>>primitiveTestAndSetOwnershipOfCriticalSection"
- (primitiveIndex = 186 or: [primitiveIndex = 187]) ifTrue:
- [| active effective |
- active := Processor activeProcess.
- effective := active effectiveProcess.
- "active == effective"
- value := primitiveIndex = 186
- ifTrue: [receiver primitiveEnterCriticalSectionOnBehalfOf: effective]
- ifFalse: [receiver primitiveTestAndSetOwnershipOfCriticalSectionOnBehalfOf: effective].
- ^(self isPrimFailToken: value)
- ifTrue: [value]
- ifFalse: [self push: value]].
-
- primitiveIndex = 188 ifTrue: "eem 5/27/2008 11:10 Object>>withArgs:executeMethod:"
- [^MethodContext
- sender: self
- receiver: receiver
- method: (arguments at: 2)
- arguments: (arguments at: 1)].
-
- "Closure primitives"
- (primitiveIndex = 200 and: [self == receiver]) ifTrue:
- "ContextPart>>closureCopy:copiedValues:; simulated to get startpc right"
- [^self push: (BlockClosure
- outerContext: receiver
- startpc: pc + 2
- numArgs: arguments first
- copiedValues: arguments last)].
-
- primitiveIndex = 118 ifTrue: "tryPrimitive:withArgs:; avoid recursing in the VM"
- [(arguments size = 2
- and: [arguments first isInteger
- and: [(self objectClass: arguments last) == Array]]) ifFalse:
- [^ContextPart primitiveFailTokenFor: nil].
- ^self doPrimitive: arguments first method: meth receiver: receiver args: arguments last].
-
- value := primitiveIndex = 120 "FFI method"
- ifTrue: [(meth literalAt: 1) tryInvokeWithArguments: arguments]
- ifFalse:
- [primitiveIndex = 117 "named primitives"
- ifTrue: [self tryNamedPrimitiveIn: meth for: receiver withArgs: arguments]
- ifFalse: [receiver tryPrimitive: primitiveIndex withArgs: arguments]].
-
- ^(self isPrimFailToken: value)
- ifTrue: [value]
- ifFalse: [self push: value]!
Item was removed:
- ----- Method: ContextPart>>ContextPartPROTOTYPEisPrimFailToken: (in category '*Cog-method prototypes') -----
- ContextPartPROTOTYPEisPrimFailToken: anObject
- ^(self objectClass: anObject) == Array
- and: [anObject size = 2
- and: [anObject first == PrimitiveFailToken]]!
Item was changed:
----- Method: Decompiler>>DecompilerPROTOTYPEdecompile:in:method:using: (in category '*Cog-method prototypes squeak 4.3') -----
DecompilerPROTOTYPEdecompile: aSelector in: aClass method: aMethod using: aConstructor
| block node |
constructor := aConstructor.
method := aMethod.
self initSymbols: aClass. "create symbol tables"
method isQuick
ifTrue: [block := self quickMethod]
ifFalse:
[stack := OrderedCollection new: method frameSize.
lastJumpIfPcStack := OrderedCollection new.
caseExits := OrderedCollection new.
statements := OrderedCollection new: 20.
numLocalTemps := 0.
super method: method pc: method initialPC.
"skip primitive error code store if necessary"
(method primitive ~= 0 and: [self skipCallPrimitive; willStore]) ifTrue:
[pc := pc + (method encoderClass bytecodeSize: self firstByte).
tempVars := tempVars asOrderedCollection].
block := self blockTo: method endPC + 1.
stack isEmpty ifFalse: [self error: 'stack not empty']].
node := constructor
codeMethod: aSelector
block: block
tempVars: tempVars
primitive: method primitive
class: aClass.
method primitive > 0 ifTrue:
[node removeAndRenameLastTempIfErrorCode].
^node preen!
Item was changed:
----- Method: InstructionStream>>InstructionStreamPROTOTYPEinterpretV3ClosuresExtension:in:for: (in category '*Cog-method prototypes') -----
InstructionStreamPROTOTYPEinterpretV3ClosuresExtension: offset in: method for: client
| type offset2 byte2 byte3 byte4 |
offset <= 6 ifTrue:
["Extended op codes 128-134"
byte2 := method at: pc. pc := pc + 1.
offset <= 2 ifTrue:
["128-130: extended pushes and pops"
type := byte2 // 64.
offset2 := byte2 \\ 64.
offset = 0 ifTrue:
[type = 0 ifTrue: [^client pushReceiverVariable: offset2].
type = 1 ifTrue: [^client pushTemporaryVariable: offset2].
type = 2 ifTrue: [^client pushConstant: (method literalAt: offset2 + 1)].
type = 3 ifTrue: [^client pushLiteralVariable: (method literalAt: offset2 + 1)]].
offset = 1 ifTrue:
[type = 0 ifTrue: [^client storeIntoReceiverVariable: offset2].
type = 1 ifTrue: [^client storeIntoTemporaryVariable: offset2].
type = 2 ifTrue: [self error: 'illegalStore'].
type = 3 ifTrue: [^client storeIntoLiteralVariable: (method literalAt: offset2 + 1)]].
offset = 2 ifTrue:
[type = 0 ifTrue: [^client popIntoReceiverVariable: offset2].
type = 1 ifTrue: [^client popIntoTemporaryVariable: offset2].
type = 2 ifTrue: [self error: 'illegalStore'].
type = 3 ifTrue: [^client popIntoLiteralVariable: (method literalAt: offset2 + 1)]]].
"131-134: extended sends"
offset = 3 ifTrue: "Single extended send"
[^client send: (method literalAt: byte2 \\ 32 + 1)
super: false numArgs: byte2 // 32].
offset = 4 ifTrue: "Double extended do-anything"
[byte3 := method at: pc. pc := pc + 1.
type := byte2 // 32.
type = 0 ifTrue: [^client send: (method literalAt: byte3 + 1)
super: false numArgs: byte2 \\ 32].
type = 1 ifTrue: [^client send: (method literalAt: byte3 + 1)
super: true numArgs: byte2 \\ 32].
type = 2 ifTrue: [^client pushReceiverVariable: byte3].
type = 3 ifTrue: [^client pushConstant: (method literalAt: byte3 + 1)].
type = 4 ifTrue: [^client pushLiteralVariable: (method literalAt: byte3 + 1)].
type = 5 ifTrue: [^client storeIntoReceiverVariable: byte3].
type = 6 ifTrue: [^client popIntoReceiverVariable: byte3].
type = 7 ifTrue: [^client storeIntoLiteralVariable: (method literalAt: byte3 + 1)]].
offset = 5 ifTrue: "Single extended send to super"
[^client send: (method literalAt: byte2 \\ 32 + 1)
super: true
numArgs: byte2 // 32].
offset = 6 ifTrue: "Second extended send"
[^client send: (method literalAt: byte2 \\ 64 + 1)
super: false
numArgs: byte2 // 64]].
offset = 7 ifTrue: [^client doPop].
offset = 8 ifTrue: [^client doDup].
offset = 9 ifTrue: [^client pushActiveContext].
byte2 := method at: pc. pc := pc + 1.
offset = 10 ifTrue:
[^byte2 < 128
ifTrue: [client pushNewArrayOfSize: byte2]
ifFalse: [client pushConsArrayWithElements: byte2 - 128]].
byte3 := method at: pc. pc := pc + 1.
offset = 11 ifTrue: [^client callPrimitive: byte2 + (byte3 bitShift: 8)].
offset = 12 ifTrue: [^client pushRemoteTemp: byte2 inVectorAt: byte3].
offset = 13 ifTrue: [^client storeIntoRemoteTemp: byte2 inVectorAt: byte3].
offset = 14 ifTrue: [^client popIntoRemoteTemp: byte2 inVectorAt: byte3].
"offset = 15"
byte4 := method at: pc. pc := pc + 1.
^client
pushClosureCopyNumCopiedValues: (byte2 bitShift: -4)
numArgs: (byte2 bitAnd: 16rF)
blockSize: (byte3 * 256) + byte4!
Item was changed:
----- Method: InstructionStream>>InstructionStreamPROTOTYPEnextPc: (in category '*Cog-method prototypes') -----
InstructionStreamPROTOTYPEnextPc: currentByte
"Answer the pc of the next bytecode following the current one, given the current bytecode.."
^pc + (self method encoderClass bytecodeSize: currentByte)!
Item was changed:
----- Method: InstructionStream>>InstructionStreamPROTOTYPEskipCallPrimitive (in category '*Cog-method prototypes') -----
InstructionStreamPROTOTYPEskipCallPrimitive
"If the receiver's method starts with a callPrimitive: bytecode, skip it."
| method encoderClass callPrimitiveCode |
method := self method.
encoderClass := method encoderClass.
callPrimitiveCode := encoderClass callPrimitiveCode.
(method byteAt: pc) = callPrimitiveCode ifTrue:
[pc := pc + (encoderClass bytecodeSize: callPrimitiveCode)]!
Item was changed:
----- Method: MCClassDefinition>>MCClassDefinitionPROTOTYPEkindOfSubclass (in category '*Cog-method prototypes squeak 4.3') -----
MCClassDefinitionPROTOTYPEkindOfSubclass
type = #normal ifTrue: [^' subclass: '].
type = #variable ifTrue: [^' variableSubclass: '].
type = #bytes ifTrue: [^' variableByteSubclass: '].
type = #compiledMethod ifTrue: [^' variableByteSubclass: ' ].
type = #words ifTrue: [^' variableWordSubclass: '].
type = #weak ifTrue: [^' weakSubclass: ' ].
type = #ephemeron ifTrue: [^' ephemeronSubclass: ' ].
type = #immediate ifTrue: [^' immediateSubclass: ' ].
self error: 'Unrecognized class type'!
Item was changed:
----- Method: MCMethodDefinition>>MCMethodDefinitionPROTOTYPEinitializeWithClassName:classIsMeta:selector:category:timeStamp:source: (in category '*Cog-method prototypes squeak 4.3') -----
MCMethodDefinitionPROTOTYPEinitializeWithClassName: classString
classIsMeta: metaBoolean
selector: selectorString
category: catString
timeStamp: timeString
source: sourceString
className := classString asSymbol.
selector := selectorString asSymbol.
category := catString ifNil: [Categorizer default] ifNotNil: [catString asSymbol].
timeStamp := timeString.
classIsMeta := metaBoolean.
source := sourceString withSqueakLineEndings!
Item was removed:
- ----- Method: MethodContext>>MethodContextPROTOTYPEfailPrimitiveWith: (in category '*Cog-method prototypes') -----
- MethodContextPROTOTYPEfailPrimitiveWith: maybePrimFailToken
- "The receiver is a freshly-created context on a primitive method. Skip the callPrimitive:
- bytecode and store the primitive fail code if there is one and the method consumes it."
- self skipCallPrimitive.
- ((self isPrimFailToken: maybePrimFailToken)
- and: [method encoderClass isStoreAt: pc in: method]) ifTrue:
- [self at: stackp put: maybePrimFailToken last]!
Item was removed:
- ----- Method: MethodContext>>xray (in category '*Cog-Tests-xrays') -----
- xray
- "Lift the veil from a context and answer an integer describing its interior state.
- Used for e.g. VM tests so they can verify they're testing what they think they're testing.
- 0 implies a vanilla heap context.
- Bit 0 = is or was married to a frame
- Bit 1 = is still married to a frame
- Bit 2 = frame is executing machine code
- Bit 3 = has machine code pc (as opposed to nil or a bytecode pc)
- Bit 4 = method is currently compiled to machine code"
- <primitive: 213>
- ^0 "Can only fail if unimplemented; therefore simply answer 0"!
Item was removed:
- ----- Method: MethodContext>>xrayIsDivorced (in category '*Cog-Tests-xrays') -----
- xrayIsDivorced
- ^(self xray bitAnd: 3) = 1!
Item was removed:
- ----- Method: MethodContext>>xrayIsExecutingMachineCode (in category '*Cog-Tests-xrays') -----
- xrayIsExecutingMachineCode
- ^self xray anyMask: 4!
Item was removed:
- ----- Method: MethodContext>>xrayIsMarried (in category '*Cog-Tests-xrays') -----
- xrayIsMarried
- ^self xray anyMask: 2!
Item was removed:
- ----- Method: MethodContext>>xrayLastExecutedMachineCode (in category '*Cog-Tests-xrays') -----
- xrayLastExecutedMachineCode
- ^self xray anyMask: 8!
Item was removed:
- ----- Method: MethodContext>>xrayMethodIsCompiledToMachineCode (in category '*Cog-Tests-xrays') -----
- xrayMethodIsCompiledToMachineCode
- ^self xray anyMask: 16!
Item was changed:
----- Method: SimulatorHarness>>withExecutableInterpreter:do: (in category 'bootstrap methods') -----
withExecutableInterpreter: sim do: aBlock
"With the oldInterpreter ready to execute code, evaluate aBlock,
then return the interpreter (and the heap) to the ``just snapshotted'' state."
| savedpc savedfp initialContext finalContext |
sim
initStackPages;
loadInitialContext;
internalizeIPandSP.
savedpc := sim localIP.
savedfp := sim localFP.
"sim printHeadFrame."
aBlock value.
"sim printHeadFrame."
sim
internalPush: sim localIP;
externalizeIPandSP.
"now undo the execution state"
self assert: sim localFP = savedfp.
initialContext := sim frameContext: savedfp.
finalContext := sim voidVMStateForSnapshotFlushingExternalPrimitivesIf: false.
self assert: initialContext = finalContext.
self assert: sim localIP = savedpc.
sim objectMemory
storePointer: SuspendedContextIndex
ofObject: sim activeProcess
withValue: finalContext!
Item was changed:
----- Method: SpurBootstrap class>>bootstrapPharoImage: (in category 'utilities') -----
bootstrapPharoImage: imageFileBaseName
+ | oldCompilerClass oldBytecodeBackend |
- | oldCompilerClass |
oldCompilerClass := SmalltalkImage compilerClass.
+ oldBytecodeBackend := CompilationContext bytecodeBackend.
[
SmalltalkImage compilerClass: Compiler.
+ CompilationContext bytecodeBackend: IRSpurSqueakV3PlusClosuresBytecodeGenerator.
self bootstrapImage: imageFileBaseName type: 'pharo' ]
+ ensure: [
+ SmalltalkImage compilerClass: oldCompilerClass.
+ CompilationContext bytecodeBackend: oldBytecodeBackend ]!
- ensure: [ SmalltalkImage compilerClass: oldCompilerClass ].
- !
Item was changed:
----- Method: SpurBootstrap>>allPrototypeMethodSymbols (in category 'method prototypes') -----
allPrototypeMethodSymbols
"self basicNew allPrototypeMethodSymbols"
| symbols |
+ "self assert: SpurBootstrap isolatedPrototypes isEmpty."
- self assert: SpurBootstrap isolatedPrototypes isEmpty.
symbols := Set new.
self prototypeClassNameMetaSelectorMethodDo:
[:className :isMeta :selector :method | | adder |
symbols
add: className;
add: selector.
adder := [:lit|
(lit isSymbol and: [lit ~~ method selector]) ifTrue: [symbols add: lit].
lit isArray ifTrue: [lit do: adder]].
method literals do: adder].
^symbols!
Item was changed:
----- Method: SpurBootstrap>>allocateClassTable (in category 'bootstrap image') -----
allocateClassTable
"Allocate the root of the classTable plus enough pages to accomodate all classes in
the classToIndex map. Don't fill in the entries yet; the classes have yet to be cloned."
| tableRoot page maxSize numPages |
tableRoot := newHeap
allocateSlots: newHeap classTableRootSlots + newHeap hiddenRootSlots
format: newHeap arrayFormat
classIndex: newHeap arrayClassIndexPun.
self assert: (newHeap numSlotsOf: tableRoot) = (newHeap classTableRootSlots + newHeap hiddenRootSlots).
self assert: (newHeap formatOf: tableRoot) = newHeap arrayFormat.
self assert: (newHeap classIndexOf: tableRoot) = newHeap arrayClassIndexPun.
newHeap nilFieldsOf: tableRoot.
"first page is strong"
page := newHeap
allocateSlots: newHeap classTablePageSize
format: newHeap arrayFormat
classIndex: newHeap arrayClassIndexPun.
self assert: (newHeap numSlotsOf: page) = newHeap classTablePageSize.
self assert: (newHeap formatOf: tableRoot) = newHeap arrayFormat.
self assert: (newHeap classIndexOf: tableRoot) = newHeap arrayClassIndexPun.
self assert: (newHeap objectAfter: tableRoot limit: newHeap freeStart) = page.
lastClassTablePage := page.
newHeap nilFieldsOf: page.
newHeap storePointer: 0 ofObject: tableRoot withValue: page.
newHeap setHiddenRootsObj: tableRoot.
maxSize := classToIndex inject: 0 into: [:a :b| a max: b].
numPages := (maxSize + newHeap classTableMinorIndexMask / newHeap classTablePageSize) truncated.
2 to: numPages do:
[:i|
page := newHeap
allocateSlots: newHeap classTablePageSize
format: newHeap arrayFormat
classIndex: newHeap arrayClassIndexPun.
self assert: (newHeap numSlotsOf: page) = newHeap classTablePageSize.
self assert: (newHeap formatOf: page) = newHeap arrayFormat.
self assert: (newHeap classIndexOf: page) = newHeap arrayClassIndexPun.
newHeap fillObj: page numSlots: newHeap classTablePageSize with: newHeap nilObject.
newHeap storePointer: i - 1 ofObject: tableRoot withValue: page.
self assert: (newHeap objectAfter: (newHeap fetchPointer: i - 2 ofObject: tableRoot) limit: newHeap freeStart) = page.
lastClassTablePage := page].
"and once again to recompute numClassTablePages post building the class table."
newHeap instVarNamed: 'numClassTablePages' put: nil.
newHeap setHiddenRootsObj: tableRoot!
Item was changed:
----- Method: SpurBootstrap>>bootstrapImageUsingFileReference: (in category 'public access') -----
bootstrapImageUsingFileReference: imageName
| dirName baseName dir |
dirName := imageName asFileReference parent fullName.
baseName := (imageName endsWith: '.image')
ifTrue: [ imageName asFileReference base ]
ifFalse: [ (imageName, '.image') asFileReference base ].
dir := dirName asFileReference.
self on: (dir / (baseName, '.image')) fullName.
[self transform]
on: Halt
do: [:ex|
"suppress halts from the usual suspects (development time halts)"
(#(fullGC compactImage) includes: ex signalerContext sender selector)
ifTrue: [ex resume]
ifFalse: [ex pass]].
self writeSnapshot: (dir / (baseName, '-spur.image')) fullName
ofTransformedImage: newHeap
headerFlags: oldInterpreter getImageHeaderFlags
screenSize: oldInterpreter savedWindowSize.
(dir / (baseName, '.changes')) copyTo: (dir / (baseName, '-spur.changes'))!
Item was changed:
----- Method: SpurBootstrap>>prototypeClassNameMetaSelectorMethodDo: (in category 'method prototypes') -----
prototypeClassNameMetaSelectorMethodDo: quaternaryBlock
"Evaluate aBlock with class name, class is meta, method and selector.
For now find methods in class-side category #'method prototypes'.
Scheme could be extended to have different protocols for different
Squeak/Pharo versions."
self allMethodPrototypes do:
+ [:eachMethod| | method className isMeta |
+ method := eachMethod.
- [:method| | className isMeta |
className := self classNameForPrototypeMethod: method.
(isMeta := className endsWith: 'class') ifTrue:
[className := (className allButLast: 5) asSymbol].
(method pragmaAt: #indirect) ifNotNil:
[method := (isMeta
ifTrue: [(Smalltalk classNamed: className) class]
ifFalse: [Smalltalk classNamed: className]) >> method selector].
quaternaryBlock
value: className
value: isMeta
value: (self selectorForPrototypeMethod: method)
value: method]!
Item was added:
+ ----- Method: SpurBootstrapMonticelloPackagePatcher>>updateTrunkRepository (in category 'repository population') -----
+ updateTrunkRepository
+ "Download all the Collections, Kernel and System packages from trunk into srcDir,
+ patch them into destDir,
+ upload the patched and branched files that aren't already in trunk to trunk."
+ "self new from: 'trunkpackages' to: 'spurpackages'; updateTrunkRepository"
+ "AndreasSystemProfiler spyOn: [self new from: 'trunkpackages' to: 'spurpackages'; updateSpurRepository]"
+ sourceDir assureExistence.
+ self download: self class squeak45baseline from: self trunk.
+ destDir assureExistence.
+ self patchAsNeeded.
+ self uploadFrom: (MCDirectoryRepository directory: destDir) to: self trunk!
Item was added:
+ ----- Method: SpurBootstrapMonticelloPackagePatcher>>versionFor: (in category 'patching') -----
+ versionFor: packageFileName
+ ^sourceDir
+ readOnlyFileNamed: packageFileName
+ do: [:fs|
+ ((MCVersionReader readerClassForFileNamed: fs fullName)
+ on: fs fileName: fs fullName)
+ version]!
Item was added:
+ SpurBootstrapSqueakFamilyPrototypes subclass: #SpurBootstrapOldSqueakPrototypes
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Cog-Bootstrapping'!
Item was added:
+ ----- Method: SpurBootstrapOldSqueakPrototypes class>>imageType (in category 'accessing') -----
+ imageType
+ ^ 'old squeak'!
Item was added:
+ ----- Method: SpurBootstrapOldSqueakPrototypes>>InstructionStreamPROTOTYPEinterpretV3ClosuresExtension:in:for: (in category 'method prototypes') -----
+ InstructionStreamPROTOTYPEinterpretV3ClosuresExtension: offset in: method for: client
+ | type offset2 byte2 byte3 byte4 |
+ offset <= 6 ifTrue:
+ ["Extended op codes 128-134"
+ byte2 := method at: pc. pc := pc + 1.
+ offset <= 2 ifTrue:
+ ["128-130: extended pushes and pops"
+ type := byte2 // 64.
+ offset2 := byte2 \\ 64.
+ offset = 0 ifTrue:
+ [type = 0 ifTrue: [^client pushReceiverVariable: offset2].
+ type = 1 ifTrue: [^client pushTemporaryVariable: offset2].
+ type = 2 ifTrue: [^client pushConstant: (method literalAt: offset2 + 1)].
+ type = 3 ifTrue: [^client pushLiteralVariable: (method literalAt: offset2 + 1)]].
+ offset = 1 ifTrue:
+ [type = 0 ifTrue: [^client storeIntoReceiverVariable: offset2].
+ type = 1 ifTrue: [^client storeIntoTemporaryVariable: offset2].
+ type = 2 ifTrue: [self error: 'illegalStore'].
+ type = 3 ifTrue: [^client storeIntoLiteralVariable: (method literalAt: offset2 + 1)]].
+ offset = 2 ifTrue:
+ [type = 0 ifTrue: [^client popIntoReceiverVariable: offset2].
+ type = 1 ifTrue: [^client popIntoTemporaryVariable: offset2].
+ type = 2 ifTrue: [self error: 'illegalStore'].
+ type = 3 ifTrue: [^client popIntoLiteralVariable: (method literalAt: offset2 + 1)]]].
+ "131-134: extended sends"
+ offset = 3 ifTrue: "Single extended send"
+ [^client send: (method literalAt: byte2 \\ 32 + 1)
+ super: false numArgs: byte2 // 32].
+ offset = 4 ifTrue: "Double extended do-anything"
+ [byte3 := method at: pc. pc := pc + 1.
+ type := byte2 // 32.
+ type = 0 ifTrue: [^client send: (method literalAt: byte3 + 1)
+ super: false numArgs: byte2 \\ 32].
+ type = 1 ifTrue: [^client send: (method literalAt: byte3 + 1)
+ super: true numArgs: byte2 \\ 32].
+ type = 2 ifTrue: [^client pushReceiverVariable: byte3].
+ type = 3 ifTrue: [^client pushConstant: (method literalAt: byte3 + 1)].
+ type = 4 ifTrue: [^client pushLiteralVariable: (method literalAt: byte3 + 1)].
+ type = 5 ifTrue: [^client storeIntoReceiverVariable: byte3].
+ type = 6 ifTrue: [^client popIntoReceiverVariable: byte3].
+ type = 7 ifTrue: [^client storeIntoLiteralVariable: (method literalAt: byte3 + 1)]].
+ offset = 5 ifTrue: "Single extended send to super"
+ [^client send: (method literalAt: byte2 \\ 32 + 1)
+ super: true
+ numArgs: byte2 // 32].
+ offset = 6 ifTrue: "Second extended send"
+ [^client send: (method literalAt: byte2 \\ 64 + 1)
+ super: false
+ numArgs: byte2 // 64]].
+ offset = 7 ifTrue: [^client doPop].
+ offset = 8 ifTrue: [^client doDup].
+ offset = 9 ifTrue: [^client pushActiveContext].
+ byte2 := method at: pc. pc := pc + 1.
+ offset = 10 ifTrue:
+ [^byte2 < 128
+ ifTrue: [client pushNewArrayOfSize: byte2]
+ ifFalse: [client pushConsArrayWithElements: byte2 - 128]].
+ byte3 := method at: pc. pc := pc + 1.
+ offset = 11 ifTrue: [^client callPrimitive: byte2 + (byte3 bitShift: 8)].
+ offset = 12 ifTrue: [^client pushRemoteTemp: byte2 inVectorAt: byte3].
+ offset = 13 ifTrue: [^client storeIntoRemoteTemp: byte2 inVectorAt: byte3].
+ offset = 14 ifTrue: [^client popIntoRemoteTemp: byte2 inVectorAt: byte3].
+ "offset = 15"
+ byte4 := method at: pc. pc := pc + 1.
+ ^client
+ pushClosureCopyNumCopiedValues: (byte2 bitShift: -4)
+ numArgs: (byte2 bitAnd: 16rF)
+ blockSize: (byte3 * 256) + byte4!
Item was changed:
----- Method: SpurBootstrapPharoPrototypes>>BehaviorPROTOTYPEbasicIdentityHash (in category 'method prototypes') -----
BehaviorPROTOTYPEbasicIdentityHash
"Answer a SmallInteger whose value is related to the receiver's identity.
Behavior implements identityHash to allow the VM to use an object representation which
does not include a direct reference to an object's class in an object. If the VM is using
this implementation then classes are held in a class table and instances contain the index
of their class in the table. A class's class table index is its identityHash so that an instance
can be created without searching the table for a class's index. The VM uses this primitive
to enter the class into the class table, assigning its identityHash with an as yet unused
class table index. If this primitive fails it means that the class table is full. In Spur as of
2014 there are 22 bits of classTable index and 22 bits of identityHash per object.
Primitive. Essential. Do not override. See Object documentation whatIsAPrimitive."
<primitive: 175>
self primitiveFailed!
Item was changed:
----- Method: SpurBootstrapPharoPrototypes>>BehaviorPROTOTYPElargeIdentityHash (in category 'method prototypes') -----
BehaviorPROTOTYPElargeIdentityHash
"Answer a SmallInteger whose value is related to the receiver's identity.
Behavior implements identityHash to allow the VM to use an object representation which
does not include a direct reference to an object's class in an object. If the VM is using
this implementation then classes are held in a class table and instances contain the index
of their class in the table. A class's class table index is its identityHash so that an instance
can be created without searching the table for a class's index. The VM uses this primitive
to enter the class into the class table, assigning its identityHash with an as yet unused
class table index. If this primitive fails it means that the class table is full. In Spur as of
2014 there are 22 bits of classTable index and 22 bits of identityHash per object."
<primitive: 175>
self primitiveFailed!
Item was changed:
----- Method: SpurBootstrapPharoPrototypes>>CharacterPROTOTYPEcodePoint (in category 'method prototypes') -----
CharacterPROTOTYPEcodePoint
"Just for ANSI Compliance"
+ ^self asciiValue!
- ^self!
Item was changed:
----- Method: SpurBootstrapPharoPrototypes>>CharacterPROTOTYPEsetValue: (in category 'method prototypes') -----
CharacterPROTOTYPEsetValue: newValue
self error: 'Characters are immutable'!
Item was added:
+ ----- Method: SpurBootstrapPharoPrototypes>>CharacterPROTOTYPEshallowCopy (in category 'method prototypes') -----
+ CharacterPROTOTYPEshallowCopy
+ "Answer the receiver, because Characters are unique."
+ ^self!
Item was added:
+ ----- Method: SpurBootstrapPharoPrototypes>>ContextPROTOTYPEobjectClass: (in category 'method prototypes') -----
+ ContextPROTOTYPEobjectClass: aReceiver
+ <indirect>!
Item was changed:
----- Method: SpurBootstrapPharoPrototypes>>ContextclassPROTOTYPEallInstances (in category 'method prototypes') -----
ContextclassPROTOTYPEallInstances
"Answer all instances of the receiver."
<primitive: 177>
"The primitive can fail because memory is low. If so, fall back on the old
enumeration code, which gives the system a chance to GC and/or grow.
Because aBlock might change the class of inst (for example, using become:),
it is essential to compute next before aBlock value: inst.
Only count until thisContext since this context has been created only to
compute the existing instances."
| inst insts next |
insts := WriteStream on: (Array new: 64).
inst := self someInstance.
[inst == thisContext or: [inst == nil]] whileFalse:
[next := inst nextInstance.
insts nextPut: inst.
inst := next].
^insts contents!
Item was changed:
----- Method: SpurBootstrapPharoPrototypes>>ContextclassPROTOTYPEallInstancesDo: (in category 'method prototypes') -----
ContextclassPROTOTYPEallInstancesDo: aBlock
"Evaluate aBlock with each of the current instances of the receiver."
| instances inst next |
instances := self allInstancesOrNil.
instances ifNotNil:
[instances do: aBlock.
^self].
"allInstancesOrNil can fail because memory is low. If so, fall back on the old
enumeration code. Because aBlock might change the class of inst (for example,
using become:), it is essential to compute next before aBlock value: inst.
Only count until thisContext since evaluation of aBlock will create new contexts."
inst := self someInstance.
[inst == thisContext or: [inst == nil]] whileFalse:
[next := inst nextInstance.
aBlock value: inst.
inst := next]!
Item was changed:
----- Method: SpurBootstrapPharoPrototypes>>ProtoObjectPROTOTYPEidentityHash (in category 'method prototypes') -----
ProtoObjectPROTOTYPEidentityHash
"Answer a SmallInteger whose value is related to the receiver's identity.
This method must not be overridden, except by SmallInteger. As of
2014, the 32-bit Spur VM has 22 bits of hash and 31-bit SmallIntegers
(30 bits + 1 sign bit). Shifting by 8 will not create large integers.
Do not override."
^self basicIdentityHash bitShift: 8!
Item was changed:
----- Method: SpurBootstrapPharoPrototypes>>SlotClassBuilderPROTOTYPEcomputeFormat:instSize:forSuper:ccIndex: (in category 'method prototypes') -----
SlotClassBuilderPROTOTYPEcomputeFormat: type instSize: newInstSize forSuper: newSuper ccIndex: ccIndex
"Compute the new format for making oldClass a subclass of newSuper.
Answer the format or nil if there is any problem."
| instSize isVar isWords isPointers isWeak |
type == #compiledMethod ifTrue:
[newInstSize > 0 ifTrue:
[self error: 'A compiled method class cannot have named instance variables'.
^nil].
^CompiledMethod format].
instSize := newInstSize + (newSuper ifNil:[0] ifNotNil:[newSuper instSize]).
instSize > 65535 ifTrue:
[self error: 'Class has too many instance variables (', instSize printString,')'.
^nil].
type == #normal ifTrue:[isVar := isWeak := false. isWords := isPointers := true].
type == #bytes ifTrue:[isVar := true. isWords := isPointers := isWeak := false].
type == #words ifTrue:[isVar := isWords := true. isPointers := isWeak := false].
type == #variable ifTrue:[isVar := isPointers := isWords := true. isWeak := false].
type == #weak ifTrue:[isVar := isWeak := isWords := isPointers := true].
type == #ephemeron ifTrue:[isVar := false. isWeak := isWords := isPointers := true].
type == #immediate ifTrue:[isVar := isWeak := isPointers := false. isWords := true].
(isPointers not and: [instSize > 0]) ifTrue:
[self error: 'A non-pointer class cannot have named instance variables'.
^nil].
^self format: instSize variable: isVar words: isWords pointers: isPointers weak: isWeak!
Item was changed:
----- Method: SpurBootstrapPharoPrototypes>>SlotClassBuilderPROTOTYPEformat:variable:words:pointers:weak: (in category 'method prototypes') -----
SlotClassBuilderPROTOTYPEformat: nInstVars variable: isVar words: isWords pointers: isPointers weak: isWeak
"Compute the format for the given instance specfication.
Above Cog Spur the class format is
<5 bits inst spec><16 bits inst size>
where the 5-bit inst spec is
0 = 0 sized objects (UndefinedObject True False et al)
1 = non-indexable objects with inst vars (Point et al)
2 = indexable objects with no inst vars (Array et al)
3 = indexable objects with inst vars (MethodContext AdditionalMethodState et al)
4 = weak indexable objects with inst vars (WeakArray et al)
5 = weak non-indexable objects with inst vars (ephemerons) (Ephemeron)
6 = unused
7 = immediates (SmallInteger, Character)
8 = unused
9 = reserved for 64-bit indexable
10-11 = 32-bit indexable (Bitmap)
12-15 = 16-bit indexable
16-23 = 8-bit indexable
24-31 = compiled methods (CompiledMethod)"
| instSpec |
instSpec := isWeak
ifTrue:
[isVar
ifTrue: [4]
ifFalse: [5]]
ifFalse:
[isPointers
ifTrue:
[isVar
ifTrue: [nInstVars > 0 ifTrue: [3] ifFalse: [2]]
ifFalse: [nInstVars > 0 ifTrue: [1] ifFalse: [0]]]
ifFalse:
[isVar
ifTrue: [isWords ifTrue: [12] ifFalse: [16]]
ifFalse: [7]]].
^(instSpec bitShift: 16) + nInstVars!
Item was changed:
----- Method: SpurBootstrapPharoPrototypes>>SlotClassBuilderPROTOTYPEsuperclass:immediateSubclass:instanceVariableNames:classVariableNames:poolDictionaries:category: (in category 'method prototypes') -----
SlotClassBuilderPROTOTYPEsuperclass: aClass
immediateSubclass: t instanceVariableNames: f
classVariableNames: d poolDictionaries: s category: cat
"This is the standard initialization message for creating a
new immediate class as a subclass of an existing class."
| env |
aClass instSize > 0
ifTrue: [^self error: 'cannot make an immediate subclass of a class with named fields'].
aClass isVariable
ifTrue: [^self error: 'cannot make an immediate subclass of a class with indexed instance variables'].
aClass isPointers
ifFalse: [^self error: 'cannot make an immediate subclass of a class without pointer fields'].
"Cope with pre-environment and environment versions. Simplify asap."
env := (Smalltalk classNamed: #EnvironmentRequest)
ifNil: [aClass environment]
ifNotNil: [:erc| erc signal ifNil: [aClass environment]].
^self
name: t
inEnvironment: env
subclassOf: aClass
type: #immediate
instanceVariableNames: f
classVariableNames: d
poolDictionaries: s
category: cat!
Item was changed:
----- Method: SpurBootstrapPharoPrototypes>>SlotClassBuilderPROTOTYPEupdate:to: (in category 'method prototypes') -----
SlotClassBuilderPROTOTYPEupdate: oldClass to: newClass
"Convert oldClass, all its instances and possibly its meta class into newClass,
instances of newClass and possibly its meta class. The process is surprisingly
simple in its implementation and surprisingly complex in its nuances and potentially
bad side effects.
We can rely on two assumptions (which are critical):
#1: The method #updateInstancesFrom: will not create any lasting pointers to
'old' instances ('old' is quote on quote since #updateInstancesFrom: will do
a become of the old vs. the new instances and therefore it will not create
pointers to *new* instances before the #become: which are *old* afterwards)
#2: The non-preemptive execution of the critical piece of code guarantees that
nobody can get a hold by 'other means' (such as process interruption and
reflection) on the old instances.
Given the above two, we know that after #updateInstancesFrom: there are no pointers
to any old instances. After the forwarding become there will be no pointers to the old
class or meta class either.
Andreas Raab, 2/27/2003 23:42"
| meta |
meta := oldClass isMeta.
"Note: Everything from here on will run without the ability to get interrupted
to prevent any other process to create new instances of the old class."
["Note: The following removal may look somewhat obscure and needs an explanation.
When we mutate the class hierarchy we create new classes for any existing subclass.
So it may look as if we don't have to remove the old class from its superclass. However,
at the top of the hierarchy (the first class we reshape) that superclass itself is not newly
created so therefore it will hold both the oldClass and newClass in its (obsolete or not)
subclasses. Since the #become: below will transparently replace the pointers to oldClass
with newClass the superclass would have newClass in its subclasses TWICE. With rather
unclear effects if we consider that we may convert the meta-class hierarchy itself (which
is derived from the non-meta class hierarchy).
Due to this problem ALL classes are removed from their superclass just prior to converting
them. Here, breaking the superclass/subclass invariant really doesn't matter since we will
effectively remove the oldClass (becomeForward:) just a few lines below."
oldClass superclass removeSubclass: oldClass.
oldClass superclass removeObsoleteSubclass: oldClass.
"make sure that the VM cache is clean"
oldClass methodDict do: [:cm | cm flushCache].
"Convert the instances of oldClass into instances of newClass"
newClass updateInstancesFrom: oldClass.
meta
ifTrue:
[oldClass becomeForward: newClass.
oldClass updateMethodBindingsTo: oldClass binding]
ifFalse:
[{oldClass. oldClass class} elementsForwardIdentityTo: {newClass. newClass class}.
oldClass updateMethodBindingsTo: oldClass binding.
oldClass class updateMethodBindingsTo: oldClass class binding].
"eem 5/31/2014 07:22 At this point there used to be a garbage collect whose purpose was
to ensure no old instances existed after the becomeForward:. Without the GC it was possible
to resurrect old instances using e.g. allInstancesDo:. This was because the becomeForward:
updated references from the old objects to new objects but didn't destroy the old objects.
But as of late 2013/early 2014 becomeForward: has been modified to free all the old objects."]
valueUnpreemptively!
Item was changed:
----- Method: SpurBootstrapPharoPrototypes>>SmalltalkImagePROTOTYPEnewSpecialObjectsArray (in category 'method prototypes') -----
SmalltalkImagePROTOTYPEnewSpecialObjectsArray
"Smalltalk recreateSpecialObjectsArray"
"To external package developers:
**** DO NOT OVERRIDE THIS METHOD. *****
If you are writing a plugin and need additional special object(s) for your own use,
use addGCRoot() function and use own, separate special objects registry "
"The Special Objects Array is an array of objects used by the Squeak virtual machine.
Its contents are critical and accesses to it by the VM are unchecked, so don't even
think of playing here unless you know what you are doing."
| newArray |
newArray := Array new: 60.
"Nil false and true get used throughout the interpreter"
newArray at: 1 put: nil.
newArray at: 2 put: false.
newArray at: 3 put: true.
"This association holds the active process (a ProcessScheduler)"
newArray at: 4 put: (self globals associationAt: #Processor).
"Numerous classes below used for type checking and instantiation"
newArray at: 5 put: Bitmap.
newArray at: 6 put: SmallInteger.
newArray at: 7 put: ByteString.
newArray at: 8 put: Array.
newArray at: 9 put: Smalltalk.
newArray at: 10 put: Float.
newArray at: 11 put: (self globals at: #MethodContext ifAbsent: [self globals at: #Context]).
newArray at: 12 put: nil. "was BlockContext."
newArray at: 13 put: Point.
newArray at: 14 put: LargePositiveInteger.
newArray at: 15 put: Display.
newArray at: 16 put: Message.
newArray at: 17 put: CompiledMethod.
newArray at: 18 put: ((self primitiveGetSpecialObjectsArray at: 18) ifNil: [Semaphore new]). "low space Semaphore"
newArray at: 19 put: Semaphore.
newArray at: 20 put: Character.
newArray at: 21 put: #doesNotUnderstand:.
newArray at: 22 put: #cannotReturn:.
newArray at: 23 put: nil. "This is the process signalling low space."
"An array of the 32 selectors that are compiled as special bytecodes,
paired alternately with the number of arguments each takes."
newArray at: 24 put: #( #+ 1 #- 1 #< 1 #> 1 #<= 1 #>= 1 #= 1 #~= 1
#* 1 #/ 1 #\\ 1 #@ 1 #bitShift: 1 #// 1 #bitAnd: 1 #bitOr: 1
#at: 1 #at:put: 2 #size 0 #next 0 #nextPut: 1 #atEnd 0 #== 1 #class 0
#blockCopy: 1 #value 0 #value: 1 #do: 1 #new 0 #new: 1 #x 0 #y 0 ).
"An array of the 255 Characters in ascii order.
Cog inlines table into machine code at: prim so do not regenerate it.
This is nil in Spur, which has immediate Characters."
newArray at: 25 put: (self primitiveGetSpecialObjectsArray at: 25).
newArray at: 26 put: #mustBeBoolean.
newArray at: 27 put: ByteArray.
newArray at: 28 put: Process.
"An array of up to 31 classes whose instances will have compact headers; an empty array in Spur"
newArray at: 29 put: self compactClassesArray.
newArray at: 30 put: ((self primitiveGetSpecialObjectsArray at: 30) ifNil: [Semaphore new]). "delay Semaphore"
newArray at: 31 put: ((self primitiveGetSpecialObjectsArray at: 31) ifNil: [Semaphore new]). "user interrupt Semaphore"
"Entries 32 - 34 unreferenced. Previously these contained prototype instances to be copied for fast initialization"
newArray at: 32 put: nil. "was the prototype Float"
newArray at: 33 put: nil. "was the prototype 4-byte LargePositiveInteger"
newArray at: 34 put: nil. "was the prototype Point"
newArray at: 35 put: #cannotInterpret:.
newArray at: 36 put: nil. "was the prototype MethodContext"
newArray at: 37 put: BlockClosure.
newArray at: 38 put: nil. "was the prototype BlockContext"
"array of objects referred to by external code"
newArray at: 39 put: (self primitiveGetSpecialObjectsArray at: 39). "external semaphores"
newArray at: 40 put: nil. "Reserved for Mutex in Cog VMs"
newArray at: 41 put: ((self primitiveGetSpecialObjectsArray at: 41) ifNil: [LinkedList new]). "Reserved for a LinkedList instance for overlapped calls in CogMT"
newArray at: 42 put: ((self primitiveGetSpecialObjectsArray at: 42) ifNil: [Semaphore new]). "finalization Semaphore"
newArray at: 43 put: LargeNegativeInteger.
"External objects for callout.
Note: Written so that one can actually completely remove the FFI."
newArray at: 44 put: (self at: #ExternalAddress ifAbsent: []).
newArray at: 45 put: (self at: #ExternalStructure ifAbsent: []).
newArray at: 46 put: (self at: #ExternalData ifAbsent: []).
newArray at: 47 put: (self at: #ExternalFunction ifAbsent: []).
newArray at: 48 put: (self at: #ExternalLibrary ifAbsent: []).
newArray at: 49 put: #aboutToReturn:through:.
newArray at: 50 put: #run:with:in:.
"51 reserved for immutability message"
newArray at: 51 put: #attemptToAssign:withIndex:.
newArray at: 52 put: #(nil "nil => generic error" #'bad receiver'
#'bad argument' #'bad index'
#'bad number of arguments'
#'inappropriate operation' #'unsupported operation'
#'no modification' #'insufficient object memory'
#'insufficient C memory' #'not found' #'bad method'
#'internal error in named primitive machinery'
#'object may move' #'resource limit exceeded'
#'object is pinned' #'primitive write beyond end of object').
"53 to 55 are for Alien"
newArray at: 53 put: (self at: #Alien ifAbsent: []).
newArray at: 54 put: #invokeCallbackContext:. "use invokeCallback:stack:registers:jmpbuf: for old Alien callbacks."
newArray at: 55 put: (self at: #UnsafeAlien ifAbsent: []).
"Used to be WeakFinalizationList for WeakFinalizationList hasNewFinalization, obsoleted by ephemeron support."
newArray at: 56 put: nil.
"reserved for foreign callback process"
newArray at: 57 put: (self primitiveGetSpecialObjectsArray at: 57 ifAbsent: []).
newArray at: 58 put: #unusedBytecode.
"59 reserved for Sista counter tripped message"
newArray at: 59 put: #conditionalBranchCounterTrippedOn:.
"60 reserved for Sista class trap message"
newArray at: 60 put: #classTrapFor:.
^newArray!
Item was changed:
----- Method: SpurBootstrapPharoPrototypes>>TraitBehaviorPROTOTYPEallInstances (in category 'method prototypes') -----
TraitBehaviorPROTOTYPEallInstances
"Answer all instances of the receiver."
self error: 'Traits does not have instances.'!
Item was changed:
----- Method: SpurBootstrapPharoPrototypes>>TraitBehaviorPROTOTYPEallInstancesDo: (in category 'method prototypes') -----
TraitBehaviorPROTOTYPEallInstancesDo: aBlock
"Evaluate aBlock with each of the current instances of the receiver."
self error: 'Traits does not have instances.'!
Item was changed:
----- Method: SpurBootstrapPharoPrototypes>>TraitBehaviorPROTOTYPEisBits (in category 'method prototypes') -----
TraitBehaviorPROTOTYPEisBits
"Answer whether the receiver contains just bits (not pointers).
Above Cog Spur the class format is
<5 bits inst spec><16 bits inst size>
where the 5-bit inst spec is
0 = 0 sized objects (UndefinedObject True False et al)
1 = non-indexable objects with inst vars (Point et al)
2 = indexable objects with no inst vars (Array et al)
3 = indexable objects with inst vars (MethodContext AdditionalMethodState et al)
4 = weak indexable objects with inst vars (WeakArray et al)
5 = weak non-indexable objects with inst vars (ephemerons) (Ephemeron)
6 = unused
7 = immediates (SmallInteger, Character)
8 = unused
9 = 64-bit indexable
10-11 = 32-bit indexable (Bitmap)
12-15 = 16-bit indexable
16-23 = 8-bit indexable
24-31 = compiled methods (CompiledMethod)"
^self instSpec >= 7!
Item was changed:
----- Method: SpurBootstrapPharoPrototypes>>TraitBehaviorPROTOTYPEisBytes (in category 'method prototypes') -----
TraitBehaviorPROTOTYPEisBytes
"Answer whether the receiver has 8-bit instance variables.
Above Cog Spur the class format is
<5 bits inst spec><16 bits inst size>
where the 5-bit inst spec is
0 = 0 sized objects (UndefinedObject True False et al)
1 = non-indexable objects with inst vars (Point et al)
2 = indexable objects with no inst vars (Array et al)
3 = indexable objects with inst vars (MethodContext AdditionalMethodState et al)
4 = weak indexable objects with inst vars (WeakArray et al)
5 = weak non-indexable objects with inst vars (ephemerons) (Ephemeron)
6 = unused
7 = immediates (SmallInteger, Character)
8 = unused
9 = 64-bit indexable
10-11 = 32-bit indexable (Bitmap)
12-15 = 16-bit indexable
16-23 = 8-bit indexable
24-31 = compiled methods (CompiledMethod)"
^self instSpec >= 16!
Item was changed:
----- Method: SpurBootstrapPharoPrototypes>>TraitBehaviorPROTOTYPEisEphemeronClass (in category 'method prototypes') -----
TraitBehaviorPROTOTYPEisEphemeronClass
"Answer whether the receiver has ephemeral instance variables. The garbage collector will
fire (queue for finalization) any ephemeron whose first instance variable is not referenced
other than from the transitive closure of references from ephemerons. Hence referring to
an object from the first inst var of an ephemeron will cause the ephemeron to fire when
the rest of the system does not refer to the object and that object is ready to be collected.
Since references from the remaining inst vars of an ephemeron will not prevent the ephemeron
from firing, ephemerons may act as the associations in weak dictionaries such that the value
(e.g. properties attached to the key) will not prevent firing when the key is no longer referenced
other than from ephemerons. Ephemerons can therefore be used to implement instance-based
pre-mortem finalization."
^self instSpec = 5!
Item was changed:
----- Method: SpurBootstrapPharoPrototypes>>TraitBehaviorPROTOTYPEisImmediateClass (in category 'method prototypes') -----
TraitBehaviorPROTOTYPEisImmediateClass
"Answer whether the receiver has immediate instances. Immediate instances
store their value in their object pointer, not in an object body. Hence immediates
take no space and are immutable. The immediates are distinguished by tag bits
in the pointer. They include SmallIntegers and Characters. Hence in the 32-bit
system SmallIntegers are 31-bit signed integers and Characters are 30-bit
unsigned character codes."
^self instSpec = 7!
Item was changed:
----- Method: SpurBootstrapPharoPrototypes>>TraitBehaviorPROTOTYPEisVariable (in category 'method prototypes') -----
TraitBehaviorPROTOTYPEisVariable
"Answer whether the receiver has indexable variables.
Above Cog Spur the class format is
<5 bits inst spec><16 bits inst size>
where the 5-bit inst spec is
0 = 0 sized objects (UndefinedObject True False et al)
1 = non-indexable objects with inst vars (Point et al)
2 = indexable objects with no inst vars (Array et al)
3 = indexable objects with inst vars (MethodContext AdditionalMethodState et al)
4 = weak indexable objects with inst vars (WeakArray et al)
5 = weak non-indexable objects with inst vars (ephemerons) (Ephemeron)
6 = unused
7 = immediates (SmallInteger, Character)
8 = unused
9 = 64-bit indexable
10-11 = 32-bit indexable (Bitmap)
12-15 = 16-bit indexable
16-23 = 8-bit indexable
24-31 = compiled methods (CompiledMethod)"
| instSpec |
instSpec := self instSpec.
^instSpec >= 2 and: [instSpec <= 4 or: [instSpec >= 9]]!
Item was changed:
----- Method: SpurBootstrapPharoPrototypes>>TraitBehaviorPROTOTYPEkindOfSubclass (in category 'method prototypes') -----
TraitBehaviorPROTOTYPEkindOfSubclass
"Answer a String that is the keyword that describes the receiver's kind of subclass,
either a regular subclass, a variableSubclass, a variableByteSubclass,
a variableWordSubclass, a weakSubclass, an ephemeronSubclass or an immediateSubclass.
c.f. typeOfClass"
^self isVariable
ifTrue:
[self isBits
ifTrue:
[self isBytes
ifTrue: [' variableByteSubclass: ']
ifFalse: [' variableWordSubclass: ']]
ifFalse:
[self isWeak
ifTrue: [' weakSubclass: ']
ifFalse: [' variableSubclass: ']]]
ifFalse:
[self isImmediateClass
ifTrue: [' immediateSubclass: ']
ifFalse:
[self isEphemeronClass
ifTrue: [' ephemeronSubclass: ']
ifFalse: [' subclass: ']]]!
Item was changed:
----- Method: SpurBootstrapPharoPrototypes>>VirtualMachinePROTOTYPEsetGCParameters (in category 'method prototypes') -----
VirtualMachinePROTOTYPEsetGCParameters
"Adjust the VM's default GC parameters to avoid too much tenuring.
Maybe this should be left to the VM?"
| proportion edenSize survivorSize averageObjectSize numObjects |
proportion := 0.9. "tenure when 90% of pastSpace is full"
edenSize := self parameterAt: 44.
survivorSize := edenSize / 5.0. "David's paper uses 140Kb eden + 2 x 28kb survivor spaces; Spur uses the same ratios :-)"
averageObjectSize := 8 * self wordSize. "a good approximation"
numObjects := (proportion * survivorSize / averageObjectSize) rounded.
self tenuringThreshold: numObjects "tenure when more than this many objects survive the GC"!
Item was changed:
----- Method: SpurBootstrapPrototypes>>BehaviorPROTOTYPEallInstances (in category 'method prototypes') -----
BehaviorPROTOTYPEallInstances
"Answer all instances of the receiver."
<primitive: 177>
"The primitive can fail because memory is low. If so, fall back on the old
enumeration code, which gives the system a chance to GC and/or grow.
Because aBlock might change the class of inst (for example, using become:),
it is essential to compute next before aBlock value: inst."
| inst insts next |
insts := WriteStream on: (Array new: 64).
inst := self someInstance.
[inst == nil] whileFalse:
[next := inst nextInstance.
(inst == insts or: [inst == insts originalContents]) ifFalse: [insts nextPut: inst].
inst := next].
^insts contents!
Item was changed:
----- Method: SpurBootstrapPrototypes>>BehaviorPROTOTYPEallInstancesDo: (in category 'method prototypes') -----
BehaviorPROTOTYPEallInstancesDo: aBlock
"Evaluate aBlock with each of the current instances of the receiver."
| instances inst next |
instances := self allInstancesOrNil.
instances ifNotNil:
[instances do: aBlock.
^self].
"allInstancesOrNil can fail because memory is low. If so, fall back on the old
enumeration code. Because aBlock might change the class of inst (for example,
using become:), it is essential to compute next before aBlock value: inst."
inst := self someInstance.
[inst == nil] whileFalse:
[next := inst nextInstance.
aBlock value: inst.
inst := next]!
Item was changed:
----- Method: SpurBootstrapPrototypes>>BehaviorPROTOTYPEallInstancesOrNil (in category 'method prototypes') -----
BehaviorPROTOTYPEallInstancesOrNil
"Answer all instances of the receiver, or nil if the primitive
fails, which it may be due to being out of memory."
<primitive: 177>
^nil!
Item was changed:
----- Method: SpurBootstrapPrototypes>>BehaviorPROTOTYPEbasicNew (in category 'method prototypes') -----
BehaviorPROTOTYPEbasicNew
"Primitive. Answer an instance of the receiver (which is a class) with no
indexable variables. Fail if the class is indexable. Essential. See Object
documentation whatIsAPrimitive.
If the primitive fails because space is low then the scavenger will run
before the method is activated. Check that space was low and retry
via handleFailingBasicNew if so."
<primitive: 70 error: ec>
ec == #'insufficient object memory' ifTrue:
[^self handleFailingBasicNew].
self isVariable ifTrue: [^self basicNew: 0].
self primitiveFailed!
Item was changed:
----- Method: SpurBootstrapPrototypes>>BehaviorPROTOTYPEbasicNew: (in category 'method prototypes') -----
BehaviorPROTOTYPEbasicNew: sizeRequested
"Primitive. Answer an instance of this class with the number of indexable
variables specified by the argument, sizeRequested. Fail if this class is not
indexable or if the argument is not a positive Integer, or if there is not
enough memory available. Essential. See Object documentation whatIsAPrimitive.
If the primitive fails because space is low then the scavenger will run before the
method is activated. Check args and retry via handleFailingBasicNew: if they're OK."
<primitive: 71 error: ec>
ec == #'insufficient object memory' ifTrue:
[^self handleFailingBasicNew: sizeRequested].
self isVariable ifFalse:
[self error: self printString, ' cannot have variable sized instances'].
self primitiveFailed!
Item was changed:
----- Method: SpurBootstrapPrototypes>>BehaviorPROTOTYPEbyteSizeOfInstance (in category 'method prototypes') -----
BehaviorPROTOTYPEbyteSizeOfInstance
"Answer the total memory size of an instance of the receiver."
<primitive: 181 error: ec>
self isVariable ifTrue:
[^self byteSizeOfInstanceOfSize: 0].
self primitiveFailed!
Item was changed:
----- Method: SpurBootstrapPrototypes>>BehaviorPROTOTYPEbyteSizeOfInstanceOfSize: (in category 'method prototypes') -----
BehaviorPROTOTYPEbyteSizeOfInstanceOfSize: basicSize
"Answer the total memory size of an instance of the receiver
with the given number of indexable instance variables."
<primitive: 181 error: ec>
self isVariable
ifTrue: "If the primitive overflowed answer a close approximation"
[(basicSize isInteger
and: [basicSize >= 16r1000000]) ifTrue:
[^2 * (self byteSizeOfInstanceOfSize: basicSize + 1 // 2)
- (self byteSizeOfInstanceOfSize: 0)]]
ifFalse:
[basicSize = 0 ifTrue:
[^self byteSizeOfInstance]].
self primitiveFailed!
Item was changed:
----- Method: SpurBootstrapPrototypes>>BehaviorPROTOTYPEelementSize (in category 'method prototypes') -----
BehaviorPROTOTYPEelementSize
"Answer the size in bytes of an element in the receiver. The formats are
0 = 0 sized objects (UndefinedObject True False et al)
1 = non-indexable objects with inst vars (Point et al)
2 = indexable objects with no inst vars (Array et al)
3 = indexable objects with inst vars (MethodContext AdditionalMethodState et al)
4 = weak indexable objects with inst vars (WeakArray et al)
5 = weak non-indexable objects with inst vars (ephemerons) (Ephemeron)
6 = unused
7 = immediates (SmallInteger, Character)
8 = unused
9 = 64-bit indexable
10-11 = 32-bit indexable (Bitmap)
12-15 = 16-bit indexable
16-23 = 8-bit indexable
24-31 = compiled methods (CompiledMethod)"
| instSpec |
instSpec := self instSpec.
instSpec < 9 ifTrue: [^Smalltalk wordSize].
instSpec >= 16 ifTrue: [^1].
instSpec >= 12 ifTrue: [^2].
instSpec >= 10 ifTrue: [^4].
^8!
Item was changed:
----- Method: SpurBootstrapPrototypes>>BehaviorPROTOTYPEhandleFailingBasicNew (in category 'method prototypes') -----
BehaviorPROTOTYPEhandleFailingBasicNew
"handleFailingBasicNew gets sent after basicNew has failed and allowed
a scavenging garbage collection to occur. The scavenging collection
will have happened as the VM is activating the (failing) basicNew. If
handleFailingBasicNew fails then the scavenge failed to reclaim sufficient
space and a global garbage collection is required. Retry after garbage
collecting and growing memory if necessary.
Primitive. Answer an instance of this class with the number of indexable
variables specified by the argument, sizeRequested. Fail if this class is not
indexable or if the argument is not a positive Integer, or if there is not
enough memory available. Essential. See Object documentation whatIsAPrimitive."
<primitive: 70>
Smalltalk garbageCollect < 1048576 ifTrue:
[Smalltalk growMemoryByAtLeast: 1048576].
^self handleFailingFailingBasicNew "retry after global garbage collect"!
Item was changed:
----- Method: SpurBootstrapPrototypes>>BehaviorPROTOTYPEhandleFailingBasicNew: (in category 'method prototypes') -----
BehaviorPROTOTYPEhandleFailingBasicNew: sizeRequested
"handleFailingBasicNew: gets sent after basicNew: has failed and allowed
a scavenging garbage collection to occur. The scavenging collection
will have happened as the VM is activating the (failing) basicNew:. If
handleFailingBasicNew: fails then the scavenge failed to reclaim sufficient
space and a global garbage collection is required. Retry after garbage
collecting and growing memory if necessary.
Primitive. Answer an instance of this class with the number of indexable
variables specified by the argument, sizeRequested. Fail if this class is not
indexable or if the argument is not a positive Integer, or if there is not
enough memory available. Essential. See Object documentation whatIsAPrimitive."
<primitive: 71>
| bytesRequested |
bytesRequested := self byteSizeOfInstanceOfSize: sizeRequested.
Smalltalk garbageCollect < bytesRequested ifTrue:
[Smalltalk growMemoryByAtLeast: bytesRequested].
"retry after global garbage collect and possible grow"
^self handleFailingFailingBasicNew: sizeRequested!
Item was changed:
----- Method: SpurBootstrapPrototypes>>BehaviorPROTOTYPEhandleFailingFailingBasicNew (in category 'method prototypes') -----
BehaviorPROTOTYPEhandleFailingFailingBasicNew
"This basicNew gets sent after handleFailingBasicNew: has done a full
garbage collection and possibly grown memory. If this basicNew fails
then the system really is low on space, so raise the OutOfMemory signal.
Primitive. Answer an instance of this class with the number of indexable
variables specified by the argument, sizeRequested. Fail if this class is not
indexable or if the argument is not a positive Integer, or if there is not
enough memory available. Essential. See Object documentation whatIsAPrimitive."
<primitive: 70>
"space must be low"
OutOfMemory signal.
^self basicNew "retry if user proceeds"!
Item was changed:
----- Method: SpurBootstrapPrototypes>>BehaviorPROTOTYPEhandleFailingFailingBasicNew: (in category 'method prototypes') -----
BehaviorPROTOTYPEhandleFailingFailingBasicNew: sizeRequested
"This basicNew: gets sent after handleFailingBasicNew: has done a full
garbage collection and possibly grown memory. If this basicNew: fails
then the system really is low on space, so raise the OutOfMemory signal.
Primitive. Answer an instance of this class with the number of indexable
variables specified by the argument, sizeRequested. Fail if this class is not
indexable or if the argument is not a positive Integer, or if there is not
enough memory available. Essential. See Object documentation whatIsAPrimitive."
<primitive: 71>
"space must be low."
OutOfMemory signal.
^self basicNew: sizeRequested "retry if user proceeds"!
Item was changed:
----- Method: SpurBootstrapPrototypes>>BehaviorPROTOTYPEindexIfCompact (in category 'method prototypes') -----
BehaviorPROTOTYPEindexIfCompact
"Backward compatibility with the Squeak V3 object format.
Spur does not have a distinction between compact and non-compact classes."
^0!
Item was changed:
----- Method: SpurBootstrapPrototypes>>BehaviorPROTOTYPEisBits (in category 'method prototypes') -----
BehaviorPROTOTYPEisBits
"Answer whether the receiver contains just bits (not pointers).
Above Cog Spur the class format is
<5 bits inst spec><16 bits inst size>
where the 5-bit inst spec is
0 = 0 sized objects (UndefinedObject True False et al)
1 = non-indexable objects with inst vars (Point et al)
2 = indexable objects with no inst vars (Array et al)
3 = indexable objects with inst vars (MethodContext AdditionalMethodState et al)
4 = weak indexable objects with inst vars (WeakArray et al)
5 = weak non-indexable objects with inst vars (ephemerons) (Ephemeron)
6 = unused
7 = immediates (SmallInteger, Character)
8 = unused
9 = 64-bit indexable
10-11 = 32-bit indexable (Bitmap)
12-15 = 16-bit indexable
16-23 = 8-bit indexable
24-31 = compiled methods (CompiledMethod)"
^self instSpec >= 7!
Item was changed:
----- Method: SpurBootstrapPrototypes>>BehaviorPROTOTYPEisBytes (in category 'method prototypes') -----
BehaviorPROTOTYPEisBytes
"Answer whether the receiver has 8-bit instance variables.
Above Cog Spur the class format is
<5 bits inst spec><16 bits inst size>
where the 5-bit inst spec is
0 = 0 sized objects (UndefinedObject True False et al)
1 = non-indexable objects with inst vars (Point et al)
2 = indexable objects with no inst vars (Array et al)
3 = indexable objects with inst vars (MethodContext AdditionalMethodState et al)
4 = weak indexable objects with inst vars (WeakArray et al)
5 = weak non-indexable objects with inst vars (ephemerons) (Ephemeron)
6 = unused
7 = immediates (SmallInteger, Character)
8 = unused
9 = 64-bit indexable
10-11 = 32-bit indexable (Bitmap)
12-15 = 16-bit indexable
16-23 = 8-bit indexable
24-31 = compiled methods (CompiledMethod)"
^self instSpec >= 16!
Item was changed:
----- Method: SpurBootstrapPrototypes>>BehaviorPROTOTYPEisEphemeronClass (in category 'method prototypes') -----
BehaviorPROTOTYPEisEphemeronClass
"Answer whether the receiver has ephemeral instance variables. The garbage collector will
fire (queue for finalization) any ephemeron whose first instance variable is not referenced
other than from the transitive closure of references from ephemerons. Hence referring to
an object from the first inst var of an ephemeron will cause the ephemeron to fire when
the rest of the system does not refer to the object and that object is ready to be collected.
Since references from the remaining inst vars of an ephemeron will not prevent the ephemeron
from firing, ephemerons may act as the associations in weak dictionaries such that the value
(e.g. properties attached to the key) will not prevent firing when the key is no longer referenced
other than from ephemerons. Ephemerons can therefore be used to implement instance-based
pre-mortem finalization."
^self instSpec = 5!
Item was changed:
----- Method: SpurBootstrapPrototypes>>BehaviorPROTOTYPEisImmediateClass (in category 'method prototypes') -----
BehaviorPROTOTYPEisImmediateClass
"Answer whether the receiver has immediate instances. Immediate instances
store their value in their object pointer, not in an object body. Hence immediates
take no space and are immutable. The immediates are distinguished by tag bits
in the pointer. They include SmallIntegers and Characters. Hence in the 32-bit
system SmallIntegers are 31-bit signed integers and Characters are 30-bit
unsigned character codes."
^self instSpec = 7!
Item was changed:
----- Method: SpurBootstrapPrototypes>>BehaviorPROTOTYPEisVariable (in category 'method prototypes') -----
BehaviorPROTOTYPEisVariable
"Answer whether the receiver has indexable variables.
Above Cog Spur the class format is
<5 bits inst spec><16 bits inst size>
where the 5-bit inst spec is
0 = 0 sized objects (UndefinedObject True False et al)
1 = non-indexable objects with inst vars (Point et al)
2 = indexable objects with no inst vars (Array et al)
3 = indexable objects with inst vars (MethodContext AdditionalMethodState et al)
4 = weak indexable objects with inst vars (WeakArray et al)
5 = weak non-indexable objects with inst vars (ephemerons) (Ephemeron)
6 = unused
7 = immediates (SmallInteger, Character)
8 = unused
9 = 64-bit indexable
10-11 = 32-bit indexable (Bitmap)
12-15 = 16-bit indexable
16-23 = 8-bit indexable
24-31 = compiled methods (CompiledMethod)"
| instSpec |
instSpec := self instSpec.
^instSpec >= 2 and: [instSpec <= 4 or: [instSpec >= 9]]!
Item was changed:
----- Method: SpurBootstrapPrototypes>>BehaviorPROTOTYPEkindOfSubclass (in category 'method prototypes') -----
BehaviorPROTOTYPEkindOfSubclass
"Answer a String that is the keyword that describes the receiver's kind of subclass,
either a regular subclass, a variableSubclass, a variableByteSubclass,
a variableWordSubclass, a weakSubclass, an ephemeronSubclass or an immediateSubclass.
c.f. typeOfClass"
^self isVariable
ifTrue:
[self isBits
ifTrue:
[self isBytes
ifTrue: [' variableByteSubclass: ']
ifFalse: [' variableWordSubclass: ']]
ifFalse:
[self isWeak
ifTrue: [' weakSubclass: ']
ifFalse: [' variableSubclass: ']]]
ifFalse:
[self isImmediateClass
ifTrue: [' immediateSubclass: ']
ifFalse:
[self isEphemeronClass
ifTrue: [' ephemeronSubclass: ']
ifFalse: [' subclass: ']]]!
Item was changed:
----- Method: SpurBootstrapPrototypes>>BehaviorPROTOTYPEshouldNotBeRedefined (in category 'method prototypes') -----
BehaviorPROTOTYPEshouldNotBeRedefined
"Answer if the receiver should not be redefined.
The assumption is that classes in Smalltalk specialObjects and
instance-specific Behaviors should not be redefined"
^(Smalltalk specialObjectsArray
identityIndexOf: self
ifAbsent: [(self isKindOf: self) ifTrue: [1] ifFalse: [0]]) ~= 0!
Item was changed:
----- Method: SpurBootstrapPrototypes>>BehaviorPROTOTYPEtypeOfClass (in category 'method prototypes') -----
BehaviorPROTOTYPEtypeOfClass
"Answer a symbol uniquely describing the type of the receiver. c.f. kindOfSubclass"
self isBytes ifTrue:
[^self instSpec = CompiledMethod instSpec
ifTrue: [#compiledMethod] "Very special!!"
ifFalse: [#bytes]].
(self isWords and: [self isPointers not]) ifTrue:
[^self instSpec = SmallInteger instSpec
ifTrue: [#immediate] "Very special!!"
ifFalse: [#words]].
self isWeak ifTrue: [^#weak].
self isVariable ifTrue: [^#variable].
self isEphemeronClass ifTrue: [^#ephemeron].
^#normal!
Item was added:
+ ----- Method: SpurBootstrapPrototypes>>BlockClosurePROTOTYPEsimulateValueWithArguments:caller: (in category 'method prototypes') -----
+ BlockClosurePROTOTYPEsimulateValueWithArguments: anArray caller: aContext
+ <indirect>!
Item was changed:
----- Method: SpurBootstrapPrototypes>>BytecodeEncoderPROTOTYPEcomputeMethodHeaderForNumArgs:numTemps:numLits:primitive: (in category 'method prototypes') -----
BytecodeEncoderPROTOTYPEcomputeMethodHeaderForNumArgs: numArgs numTemps: numTemps numLits: numLits primitive: primitiveIndex
numArgs > 15 ifTrue:
[^self error: 'Cannot compile -- too many arguments'].
numTemps > 63 ifTrue:
[^self error: 'Cannot compile -- too many temporary variables'].
numLits > 65535 ifTrue:
[^self error: 'Cannot compile -- too many literals'].
^(CompiledMethod headerFlagForEncoder: self)
+ (numArgs bitShift: 24)
+ (numTemps bitShift: 18)
"+ (largeBit bitShift: 17)" "largeBit gets filled in later"
+ (primitiveIndex > 0 ifTrue: [1 bitShift: 16] ifFalse: [0])
+ numLits!
Item was changed:
----- Method: SpurBootstrapPrototypes>>BytecodeEncoderPROTOTYPEsizeCallPrimitive: (in category 'method prototypes') -----
BytecodeEncoderPROTOTYPEsizeCallPrimitive: primitiveIndex
^self sizeOpcodeSelector: #genCallPrimitive: withArguments: {primitiveIndex}!
Item was changed:
----- Method: SpurBootstrapPrototypes>>CharacterPROTOTYPEDollarEquals: (in category 'method prototypes') -----
CharacterPROTOTYPEDollarEquals: aCharacter
"Primitive. Answer if the receiver and the argument are the
same object (have the same object pointer). Optional. See
Object documentation whatIsAPrimitive."
<primitive: 110>
^self == aCharacter!
Item was changed:
----- Method: SpurBootstrapPrototypes>>CharacterPROTOTYPEasInteger (in category 'method prototypes') -----
CharacterPROTOTYPEasInteger
"Answer the receiver's character code."
<primitive: 171>
^self primitiveFailed!
Item was changed:
----- Method: SpurBootstrapPrototypes>>CharacterPROTOTYPEasciiValue (in category 'method prototypes') -----
CharacterPROTOTYPEasciiValue
"Answer the receiver's character code.
This will be ascii for characters with value <= 127,
and Unicode for those with higher values."
<primitive: 171>
^self primitiveFailed!
Item was changed:
----- Method: SpurBootstrapPrototypes>>CharacterPROTOTYPEcopy (in category 'method prototypes') -----
CharacterPROTOTYPEcopy
"Answer the receiver, because Characters are unique."
^self!
Item was changed:
----- Method: SpurBootstrapPrototypes>>CharacterPROTOTYPEdeepCopy (in category 'method prototypes') -----
CharacterPROTOTYPEdeepCopy
"Answer the receiver, because Characters are unique."
^self!
Item was changed:
----- Method: SpurBootstrapPrototypes>>CharacterPROTOTYPEhash (in category 'method prototypes') -----
CharacterPROTOTYPEhash
"Hash is reimplemented because = is implemented.
Answer the receiver's character code."
<primitive: 171>
^self primitiveFailed!
Item was changed:
----- Method: SpurBootstrapPrototypes>>CharacterPROTOTYPEidentityHash (in category 'method prototypes') -----
CharacterPROTOTYPEidentityHash
"Answer the receiver's character code."
<primitive: 171>
^self primitiveFailed!
Item was changed:
----- Method: SpurBootstrapPrototypes>>CharacterPROTOTYPEveryDeepCopyWith: (in category 'method prototypes') -----
CharacterPROTOTYPEveryDeepCopyWith: deepCopier
"Answer the receiver, because Characters are unique."
^self!
Item was changed:
----- Method: SpurBootstrapPrototypes>>CharacterclassPROTOTYPEdigitValue: (in category 'method prototypes') -----
CharacterclassPROTOTYPEdigitValue: x
"Answer the Character whose digit value is x. For example,
answer $9 for x=9, $0 for x=0, $A for x=10, $Z for x=35."
| n |
n := x asInteger.
^self value: (n < 10 ifTrue: [n + 48] ifFalse: [n + 55])!
Item was changed:
----- Method: SpurBootstrapPrototypes>>CharacterclassPROTOTYPEinitialize (in category 'method prototypes') -----
CharacterclassPROTOTYPEinitialize
"Create the DigitsValues table."
"Character initialize"
self initializeDigitValues!
Item was changed:
----- Method: SpurBootstrapPrototypes>>CharacterclassPROTOTYPEvalue: (in category 'method prototypes') -----
CharacterclassPROTOTYPEvalue: anInteger
"Answer the Character whose value is anInteger."
<primitive: 170>
^self primitiveFailed!
Item was removed:
- ----- Method: SpurBootstrapPrototypes>>ClassBuilderPROTOTYPEcomputeFormat:instSize:forSuper:ccIndex: (in category 'method prototypes') -----
- ClassBuilderPROTOTYPEcomputeFormat: type instSize: newInstSize forSuper: newSuper ccIndex: ccIndex
- "Compute the new format for making oldClass a subclass of newSuper.
- Answer the format or nil if there is any problem."
- | instSize isVar isWords isPointers isWeak |
- type == #compiledMethod ifTrue:
- [newInstSize > 0 ifTrue:
- [self error: 'A compiled method class cannot have named instance variables'.
- ^nil].
- ^CompiledMethod format].
- instSize := newInstSize + (newSuper ifNil:[0] ifNotNil:[newSuper instSize]).
- instSize > 65535 ifTrue:
- [self error: 'Class has too many instance variables (', instSize printString,')'.
- ^nil].
- type == #normal ifTrue:[isVar := isWeak := false. isWords := isPointers := true].
- type == #bytes ifTrue:[isVar := true. isWords := isPointers := isWeak := false].
- type == #words ifTrue:[isVar := isWords := true. isPointers := isWeak := false].
- type == #variable ifTrue:[isVar := isPointers := isWords := true. isWeak := false].
- type == #weak ifTrue:[isVar := isWeak := isWords := isPointers := true].
- type == #ephemeron ifTrue:[isVar := false. isWeak := isWords := isPointers := true].
- type == #immediate ifTrue:[isVar := isWeak := isPointers := false. isWords := true].
- (isPointers not and: [instSize > 0]) ifTrue:
- [self error: 'A non-pointer class cannot have named instance variables'.
- ^nil].
- ^self format: instSize variable: isVar words: isWords pointers: isPointers weak: isWeak!
Item was removed:
- ----- Method: SpurBootstrapPrototypes>>ClassBuilderPROTOTYPEformat:variable:words:pointers:weak: (in category 'method prototypes') -----
- ClassBuilderPROTOTYPEformat: nInstVars variable: isVar words: is32BitWords pointers: isPointers weak: isWeak
- "Compute the format for the given instance specfication.
- Above Cog Spur the class format is
- <5 bits inst spec><16 bits inst size>
- where the 5-bit inst spec is
- 0 = 0 sized objects (UndefinedObject True False et al)
- 1 = non-indexable objects with inst vars (Point et al)
- 2 = indexable objects with no inst vars (Array et al)
- 3 = indexable objects with inst vars (MethodContext AdditionalMethodState et al)
- 4 = weak indexable objects with inst vars (WeakArray et al)
- 5 = weak non-indexable objects with inst vars (ephemerons) (Ephemeron)
- 6 = unused
- 7 = immediates (SmallInteger, Character)
- 8 = unused
- 9 = reserved for 64-bit indexable
- 10-11 = 32-bit indexable (Bitmap)
- 12-15 = 16-bit indexable
- 16-23 = 8-bit indexable
- 24-31 = compiled methods (CompiledMethod)"
- | instSpec |
- instSpec := isWeak
- ifTrue:
- [isVar
- ifTrue: [4]
- ifFalse: [5]]
- ifFalse:
- [isPointers
- ifTrue:
- [isVar
- ifTrue: [nInstVars > 0 ifTrue: [3] ifFalse: [2]]
- ifFalse: [nInstVars > 0 ifTrue: [1] ifFalse: [0]]]
- ifFalse:
- [isVar
- ifTrue: [is32BitWords ifTrue: [10] ifFalse: [16]]
- ifFalse: [7]]].
- ^(instSpec bitShift: 16) + nInstVars!
Item was removed:
- ----- Method: SpurBootstrapPrototypes>>ClassBuilderPROTOTYPEsuperclass:immediateSubclass:instanceVariableNames:classVariableNames:poolDictionaries:category: (in category 'method prototypes') -----
- ClassBuilderPROTOTYPEsuperclass: aClass
- immediateSubclass: t instanceVariableNames: f
- classVariableNames: d poolDictionaries: s category: cat
- "This is the standard initialization message for creating a
- new immediate class as a subclass of an existing class."
- | env |
- aClass instSize > 0
- ifTrue: [^self error: 'cannot make an immediate subclass of a class with named fields'].
- aClass isVariable
- ifTrue: [^self error: 'cannot make an immediate subclass of a class with indexed instance variables'].
- aClass isPointers
- ifFalse: [^self error: 'cannot make an immediate subclass of a class without pointer fields'].
- "Cope with pre-environment and environment versions. Simplify asap."
- env := (Smalltalk classNamed: #EnvironmentRequest)
- ifNil: [aClass environment]
- ifNotNil: [:erc| erc signal ifNil: [aClass environment]].
- ^self
- name: t
- inEnvironment: env
- subclassOf: aClass
- type: #immediate
- instanceVariableNames: f
- classVariableNames: d
- poolDictionaries: s
- category: cat!
Item was removed:
- ----- Method: SpurBootstrapPrototypes>>ClassBuilderPROTOTYPEupdate:to: (in category 'method prototypes') -----
- ClassBuilderPROTOTYPEupdate: oldClass to: newClass
- "Convert oldClass, all its instances and possibly its meta class into newClass,
- instances of newClass and possibly its meta class. The process is surprisingly
- simple in its implementation and surprisingly complex in its nuances and potentially
- bad side effects.
- We can rely on two assumptions (which are critical):
- #1: The method #updateInstancesFrom: will not create any lasting pointers to
- 'old' instances ('old' is quote on quote since #updateInstancesFrom: will do
- a become of the old vs. the new instances and therefore it will not create
- pointers to *new* instances before the #become: which are *old* afterwards)
- #2: The non-preemptive execution of the critical piece of code guarantees that
- nobody can get a hold by 'other means' (such as process interruption and
- reflection) on the old instances.
- Given the above two, we know that after #updateInstancesFrom: there are no pointers
- to any old instances. After the forwarding become there will be no pointers to the old
- class or meta class either.
- Andreas Raab, 2/27/2003 23:42"
- | meta |
- meta := oldClass isMeta.
- "Note: Everything from here on will run without the ability to get interrupted
- to prevent any other process to create new instances of the old class."
- ["Note: The following removal may look somewhat obscure and needs an explanation.
- When we mutate the class hierarchy we create new classes for any existing subclass.
- So it may look as if we don't have to remove the old class from its superclass. However,
- at the top of the hierarchy (the first class we reshape) that superclass itself is not newly
- created so therefore it will hold both the oldClass and newClass in its (obsolete or not)
- subclasses. Since the #become: below will transparently replace the pointers to oldClass
- with newClass the superclass would have newClass in its subclasses TWICE. With rather
- unclear effects if we consider that we may convert the meta-class hierarchy itself (which
- is derived from the non-meta class hierarchy).
- Due to this problem ALL classes are removed from their superclass just prior to converting
- them. Here, breaking the superclass/subclass invariant really doesn't matter since we will
- effectively remove the oldClass (becomeForward:) just a few lines below."
-
- oldClass superclass removeSubclass: oldClass.
- oldClass superclass removeObsoleteSubclass: oldClass.
-
- "make sure that the VM cache is clean"
- oldClass methodDict do: [:cm | cm flushCache].
-
- "Convert the instances of oldClass into instances of newClass"
- newClass updateInstancesFrom: oldClass.
-
- meta
- ifTrue:
- [oldClass becomeForward: newClass.
- oldClass updateMethodBindingsTo: oldClass binding]
- ifFalse:
- [{oldClass. oldClass class} elementsForwardIdentityTo: {newClass. newClass class}.
- oldClass updateMethodBindingsTo: oldClass binding.
- oldClass class updateMethodBindingsTo: oldClass class binding].
-
- "eem 5/31/2014 07:22 At this point there used to be a garbage collect whose purpose was
- to ensure no old instances existed after the becomeForward:. Without the GC it was possible
- to resurrect old instances using e.g. allInstancesDo:. This was because the becomeForward:
- updated references from the old objects to new objects but didn't destroy the old objects.
- But as of late 2013/early 2014 becomeForward: has been modified to free all the old objects."]
- valueUnpreemptively!
Item was changed:
----- Method: SpurBootstrapPrototypes>>CompiledMethodPROTOTYPEnumLiterals (in category 'method prototypes') -----
CompiledMethodPROTOTYPEnumLiterals
"Answer the number of literals used by the receiver."
^self header bitAnd: 65535!
Item was changed:
----- Method: SpurBootstrapPrototypes>>CompiledMethodPROTOTYPEprimitive (in category 'method prototypes') -----
CompiledMethodPROTOTYPEprimitive
"Answer the primitive index associated with the receiver.
Zero indicates that this is not a primitive method."
| initialPC |
^(self header anyMask: 65536) "Is the hasPrimitive? flag set?"
ifTrue: [(self at: (initialPC := self initialPC) + 1) + ((self at: initialPC + 2) bitShift: 8)]
ifFalse: [0]!
Item was changed:
----- Method: SpurBootstrapPrototypes>>CompiledMethodclassPROTOTYPEhandleFailingFailingNewMethod:header: (in category 'method prototypes') -----
CompiledMethodclassPROTOTYPEhandleFailingFailingNewMethod: numberOfBytes header: headerWord
"This newMethod:header: gets sent after handleFailingBasicNew: has done a full
garbage collection and possibly grown memory. If this basicNew: fails then the
system really is low on space, so raise the OutOfMemory signal.
Primitive. Answer an instance of this class with the number of indexable variables
specified by the argument, headerWord, and the number of bytecodes specified
by numberOfBytes. Fail if this if the arguments are not Integers, or if numberOfBytes
is negative, or if the receiver is not a CompiledMethod class, or if there is not enough
memory available. Essential. See Object documentation whatIsAPrimitive."
<primitive: 79>
"space must be low."
OutOfMemory signal.
"retry if user proceeds"
^self newMethod: numberOfBytes header: headerWord!
Item was changed:
----- Method: SpurBootstrapPrototypes>>CompiledMethodclassPROTOTYPEhandleFailingNewMethod:header: (in category 'method prototypes') -----
CompiledMethodclassPROTOTYPEhandleFailingNewMethod: numberOfBytes header: headerWord
"This newMethod:header: gets sent after newMethod:header: has failed
and allowed a scavenging garbage collection to occur. The scavenging
collection will have happened as the VM is activating the (failing) basicNew:.
If handleFailingBasicNew: fails then the scavenge failed to reclaim sufficient
space and a global garbage collection is required. Retry after garbage
collecting and growing memory if necessary.
Primitive. Answer an instance of this class with the number of indexable variables
specified by the argument, headerWord, and the number of bytecodes specified
by numberOfBytes. Fail if this if the arguments are not Integers, or if numberOfBytes
is negative, or if the receiver is not a CompiledMethod class, or if there is not enough
memory available. Essential. See Object documentation whatIsAPrimitive."
<primitive: 79>
| bytesRequested |
bytesRequested := (headerWord bitAnd: 16rFFFF) + 1 * Smalltalk wordSize + numberOfBytes + 16.
Smalltalk garbageCollect < bytesRequested ifTrue:
[Smalltalk growMemoryByAtLeast: bytesRequested].
"retry after global garbage collect and possible grow"
^self handleFailingFailingNewMethod: numberOfBytes header: headerWord!
Item was changed:
----- Method: SpurBootstrapPrototypes>>CompiledMethodclassPROTOTYPEheaderFlagForEncoder: (in category 'method prototypes') -----
CompiledMethodclassPROTOTYPEheaderFlagForEncoder: anEncoder
<indirect>!
Item was changed:
----- Method: SpurBootstrapPrototypes>>CompiledMethodclassPROTOTYPEinitialize (in category 'method prototypes') -----
CompiledMethodclassPROTOTYPEinitialize "CompiledMethod initialize"
<indirect>!
Item was changed:
----- Method: SpurBootstrapPrototypes>>CompiledMethodclassPROTOTYPEinstallPrimaryBytecodeSet: (in category 'method prototypes') -----
CompiledMethodclassPROTOTYPEinstallPrimaryBytecodeSet: aBytecodeEncoderSubclass
<indirect>!
Item was changed:
----- Method: SpurBootstrapPrototypes>>CompiledMethodclassPROTOTYPEinstallSecondaryBytecodeSet: (in category 'method prototypes') -----
CompiledMethodclassPROTOTYPEinstallSecondaryBytecodeSet: aBytecodeEncoderSubclass
<indirect>!
Item was changed:
----- Method: SpurBootstrapPrototypes>>CompiledMethodclassPROTOTYPEnewBytes:trailerBytes:nArgs:nTemps:nStack:nLits:primitive: (in category 'method prototypes') -----
CompiledMethodclassPROTOTYPEnewBytes: numberOfBytes trailerBytes: trailer nArgs: nArgs nTemps: nTemps nStack: stackSize nLits: nLits primitive: primitiveIndex
"Since this method refers to ClassVariables things are easier if it lives in the actual class."
<indirect>!
Item was changed:
----- Method: SpurBootstrapPrototypes>>CompiledMethodclassPROTOTYPEnewBytes:trailerBytes:nArgs:nTemps:nStack:nLits:primitive:flag: (in category 'method prototypes') -----
CompiledMethodclassPROTOTYPEnewBytes: numberOfBytes trailerBytes: trailer nArgs: nArgs nTemps: nTemps nStack: stackSize nLits: nLits primitive: primitiveIndex flag: flag
"Since this method refers to ClassVariables things are easier if it lives in the actual class."
<indirect>!
Item was changed:
----- Method: SpurBootstrapPrototypes>>CompiledMethodclassPROTOTYPEnewMethod:header: (in category 'method prototypes') -----
CompiledMethodclassPROTOTYPEnewMethod: numberOfBytes header: headerWord
"Primitive. Answer an instance of me. The number of literals (and other
information) is specified by the headerWord (see my class comment).
The first argument specifies the number of fields for bytecodes in the
method. Fail if either argument is not a SmallInteger, or if numberOfBytes
is negative, or if memory is low. Once the header of a method is set by
this primitive, it cannot be changed to change the number of literals.
Essential. See Object documentation whatIsAPrimitive."
<primitive: 79 error: ec>
ec == #'insufficient object memory' ifTrue:
[^self handleFailingNewMethod: numberOfBytes header: headerWord].
^self primitiveFailed!
Item was changed:
----- Method: SpurBootstrapPrototypes>>CompiledMethodclassPROTOTYPEtoReturnConstant:trailerBytes: (in category 'method prototypes') -----
CompiledMethodclassPROTOTYPEtoReturnConstant: index trailerBytes: trailer
"Answer an instance of me that is a quick return of the constant
indexed in (true false nil -1 0 1 2)."
^self newBytes: 3 trailerBytes: trailer nArgs: 0 nTemps: 0 nStack: 0 nLits: 2 primitive: 256 + index!
Item was changed:
----- Method: SpurBootstrapPrototypes>>CompiledMethodclassPROTOTYPEtoReturnField:trailerBytes: (in category 'method prototypes') -----
CompiledMethodclassPROTOTYPEtoReturnField: field trailerBytes: trailer
"Answer an instance of me that is a quick return of the instance variable
indexed by the argument, field."
^self newBytes: 3 trailerBytes: trailer nArgs: 0 nTemps: 0 nStack: 0 nLits: 2 primitive: 264 + field!
Item was changed:
----- Method: SpurBootstrapPrototypes>>CompiledMethodclassPROTOTYPEtoReturnSelfTrailerBytes: (in category 'method prototypes') -----
CompiledMethodclassPROTOTYPEtoReturnSelfTrailerBytes: trailer
"Answer an instance of me that is a quick return of the instance (^self)."
^self newBytes: 3 trailerBytes: trailer nArgs: 0 nTemps: 0 nStack: 0 nLits: 2 primitive: 256!
Item was changed:
----- Method: SpurBootstrapPrototypes>>EncoderForV3PROTOTYPEcomputeMethodHeaderForNumArgs:numTemps:numLits:primitive: (in category 'method prototypes') -----
EncoderForV3PROTOTYPEcomputeMethodHeaderForNumArgs: numArgs numTemps: numTemps numLits: numLits primitive: primitiveIndex
<remove>!
Item was changed:
----- Method: SpurBootstrapPrototypes>>EncoderForV3PlusClosuresPROTOTYPEgenCallPrimitive: (in category 'method prototypes') -----
EncoderForV3PlusClosuresPROTOTYPEgenCallPrimitive: primitiveIndex
"Since this method has inst var refs the prototype must live in the actual class."
<indirect>!
Item was changed:
----- Method: SpurBootstrapPrototypes>>EncoderForV3PlusClosuresclassPROTOTYPEbytecodeSize: (in category 'method prototypes') -----
EncoderForV3PlusClosuresclassPROTOTYPEbytecodeSize: bytecode
"Answer the number of bytes in the bytecode."
bytecode <= 125 ifTrue:
[^1].
bytecode >= 176 ifTrue:
[^1].
bytecode >= 160 ifTrue: "long jumps"
[^2].
bytecode >= 144 ifTrue: "short jumps"
[^1].
"extensions"
bytecode >= 128 ifTrue:
[^#(2 2 2 2 3 2 2 1 1 1 2 3 3 3 3 4) at: bytecode - 127].
^nil!
Item was changed:
----- Method: SpurBootstrapPrototypes>>EncoderForV3PlusClosuresclassPROTOTYPEcallPrimitiveCode (in category 'method prototypes') -----
EncoderForV3PlusClosuresclassPROTOTYPEcallPrimitiveCode
"139 11101111 iiiiiiii jjjjjjjj Call Primitive #iiiiiiii + (jjjjjjjj * 256)"
^139!
Item was changed:
----- Method: SpurBootstrapPrototypes>>InstructionClientPROTOTYPEcallPrimitive: (in category 'method prototypes') -----
InstructionClientPROTOTYPEcallPrimitive: pimIndex
"V3PlusClosures: 139 10001011 iiiiiiii jjjjjjjj Call Primitive #iiiiiiii + (jjjjjjjj * 256)
NewsqueakV4: 249 11111001 iiiiiiii jjjjjjjj Call Primitive #iiiiiiii + (jjjjjjjj * 256)
SistaV1: 248 11111000 iiiiiiii mjjjjjjj Call Primitive #iiiiiiii + ( jjjjjjj * 256)
m=1 means inlined primitive, no hard return after execution."!
Item was removed:
- ----- Method: SpurBootstrapPrototypes>>InstructionPrinterPROTOTYPEcallPrimitive: (in category 'method prototypes') -----
- InstructionPrinterPROTOTYPEcallPrimitive: index
- "Print the callPrimitive."
-
- self print: 'callPrimtive: ' , index printString!
Item was changed:
----- Method: SpurBootstrapPrototypes>>MethodNodeOLDSQUEAKPROTOTYPEgenerate: (in category 'method prototypes') -----
MethodNodeOLDSQUEAKPROTOTYPEgenerate: trailer
"The receiver is the root of a parse tree. Answer a CompiledMethod.
The argument, trailer, is arbitrary but is typically either the reference
to the source code that is stored with every CompiledMethod, or an
encoding of the method's temporary names."
^self generate: trailer using: CompiledMethod!
Item was changed:
----- Method: SpurBootstrapPrototypes>>MethodNodePROTOTYPEgenerate:using: (in category 'method prototypes') -----
MethodNodePROTOTYPEgenerate: trailer using: aCompiledMethodClass
"Since this method has inst var refs the prototype must live in the actual class."
<indirect>!
Item was changed:
----- Method: SpurBootstrapPrototypes>>SmallIntegerPROTOTYPEasCharacter (in category 'method prototypes') -----
SmallIntegerPROTOTYPEasCharacter
<primitive: 170>
^self primitiveFailed!
Item was changed:
----- Method: SpurBootstrapPrototypes>>SmalltalkImagePROTOTYPEcompactClassesArray (in category 'method prototypes') -----
SmalltalkImagePROTOTYPEcompactClassesArray
"Smalltalk compactClassesArray"
"Backward-compatibility support. Spur does not have compact classes."
^{}!
Item was changed:
----- Method: SpurBootstrapPrototypes>>SmalltalkImagePROTOTYPEgrowMemoryByAtLeast: (in category 'method prototypes') -----
SmalltalkImagePROTOTYPEgrowMemoryByAtLeast: numBytes
"Grow memory by at least the requested number of bytes.
Primitive. Essential. Fail if no memory is available."
<primitive: 180>
(numBytes isInteger and: [numBytes > 0]) ifTrue:
[OutOfMemory signal].
^self primitiveFailed!
Item was changed:
----- Method: SpurBootstrapPrototypes>>SmalltalkImagePROTOTYPEmaxIdentityHash (in category 'method prototypes') -----
SmalltalkImagePROTOTYPEmaxIdentityHash
"Answer the maximum identityHash value supported by the VM."
<primitive: 176>
^self primitiveFailed!
Item was changed:
----- Method: SpurBootstrapPrototypes>>SpaceTallyPROTOTYPEspaceForInstancesOf: (in category 'method prototypes') -----
SpaceTallyPROTOTYPEspaceForInstancesOf: aClass
"Answer a pair of the number of bytes consumed by all instances of the
given class, including their object headers, and the number of instances."
| instances total |
instances := aClass allInstances.
instances isEmpty ifTrue: [^#(0 0)].
total := 0.
aClass isVariable
ifTrue:
[instances do:
[:i| total := total + (aClass byteSizeOfInstanceOfSize: i basicSize)]]
ifFalse:
[total := instances size * aClass byteSizeOfInstance].
^{ total. instances size }!
Item was changed:
----- Method: SpurBootstrapPrototypes>>SystemDictionaryPROTOTYPEgrowMemoryByAtLeast: (in category 'method prototypes') -----
SystemDictionaryPROTOTYPEgrowMemoryByAtLeast: numBytes
"Grow memory by at least the requested number of bytes.
Primitive. Fail if no memory is available. Essential."
<primitive: 180>
^(numBytes isInteger and: [numBytes > 0])
ifTrue: [OutOfMemory signal]
ifFalse: [self primitiveFailed]!
Item was changed:
----- Method: SpurBootstrapPrototypes>>SystemDictionaryPROTOTYPEmaxIdentityHash (in category 'method prototypes') -----
SystemDictionaryPROTOTYPEmaxIdentityHash
"Answer the maximum identityHash value supported by the VM."
<primitive: 176>
^self primitiveFailed!
Item was changed:
----- Method: SpurBootstrapPrototypes>>SystemNavigationPROTOTYPEallObjects (in category 'method prototypes') -----
SystemNavigationPROTOTYPEallObjects
"Answer an Array of all objects in the system. Fail if
there isn't enough memory to instantiate the result."
<primitive: 178>
^self primitiveFailed!
Item was changed:
----- Method: SpurBootstrapPrototypes>>SystemNavigationPROTOTYPEallObjectsDo: (in category 'method prototypes') -----
SystemNavigationPROTOTYPEallObjectsDo: aBlock
"Evaluate the argument, aBlock, for each object in the system, excluding immediates
such as SmallInteger and Character."
self allObjectsOrNil
ifNotNil: [:allObjects| allObjects do: aBlock]
ifNil:
["Fall back on the old single object primitive code. With closures, this needs
to use an end marker (lastObject) since activation of the block will create
new contexts and cause an infinite loop. The lastObject must be created
before calling someObject, so that the VM can settle the enumeration (e.g.
by flushing new space) as a side effect of someObject"
| object lastObject |
lastObject := Object new.
object := self someObject.
[lastObject == object or: [0 == object]] whileFalse:
[aBlock value: object.
object := object nextObject]]!
Item was changed:
----- Method: SpurBootstrapPrototypes>>SystemNavigationPROTOTYPEallObjectsOrNil (in category 'method prototypes') -----
SystemNavigationPROTOTYPEallObjectsOrNil
"Answer an Array of all objects in the system. Fail if there isn't
enough memory to instantiate the result and answer nil."
<primitive: 178>
^nil!
Item was changed:
----- Method: SpurBootstrapPrototypes>>WideStringPROTOTYPEat: (in category 'method prototypes') -----
WideStringPROTOTYPEat: index
"Answer the Character stored in the field of the receiver indexed by the
argument. Primitive. Fail if the index argument is not an Integer or is out
of bounds. Essential. See Object documentation whatIsAPrimitive."
<primitive: 63>
^index isInteger
ifTrue:
[self errorSubscriptBounds: index]
ifFalse:
[index isNumber
ifTrue: [self at: index asInteger]
ifFalse: [self errorNonIntegerIndex]]!
Item was changed:
----- Method: SpurBootstrapPrototypes>>WideStringPROTOTYPEat:put: (in category 'method prototypes') -----
WideStringPROTOTYPEat: index put: aCharacter
"Store the Character into the field of the receiver indicated by the index.
Primitive. Fail if the index is not an Integer or is out of bounds, or if the
argument is not a Character. Essential. See Object documentation whatIsAPrimitive."
<primitive: 64>
^aCharacter isCharacter
ifTrue:
[index isInteger
ifTrue: [self errorSubscriptBounds: index]
ifFalse: [self errorNonIntegerIndex]]
ifFalse:
[self errorImproperStore]!
Item was added:
+ ----- Method: SpurBootstrapPrototypes>>categoryForClass:meta:selector: (in category 'method prototype categorization') -----
+ categoryForClass: className meta: isMeta selector: selector
+ ^(isMeta
+ ifTrue: [{ className. #class. selector }]
+ ifFalse: [{ className. selector }])
+ caseOf: {
+ [#(Behavior allInstancesOrNil)] -> [#enumerating].
+ [#(Behavior byteSizeOfInstance)] -> [#'accessing instances and variables'].
+ [#(Behavior byteSizeOfInstanceOfSize:)] -> [#'accessing instances and variables'].
+ [#(Behavior elementSize)] -> [#'accessing instances and variables'].
+ [#(Behavior handleFailingBasicNew)] -> [#private].
+ [#(Behavior handleFailingBasicNew:)] -> [#private].
+ [#(Behavior handleFailingFailingBasicNew)] -> [#private].
+ [#(Behavior handleFailingFailingBasicNew:)] -> [#private].
+ [#(Behavior identityHash)] -> [#comparing].
+ [#(Behavior isEphemeronClass)] -> [#testing].
+ [#(Behavior isImmediateClass)] -> [#testing].
+ [#(Character identityHash)] -> [#comparing].
+ [#(Class immediateSubclass:instanceVariableNames:classVariableNames:poolDictionaries:category:)]
+ -> [#'subclass creation'].
+ [#(ClassBuilder superclass:immediateSubclass:instanceVariableNames:classVariableNames:poolDictionaries:category:)]
+ -> [#public].
+ [#(CompiledMethod class handleFailingFailingNewMethod:header:)]
+ -> [#private].
+ [#(CompiledMethod class handleFailingNewMethod:header:)]
+ -> [#private].
+ [#(Context class allInstances)] -> [#enumerating].
+ [#(Context class allInstancesDo:)] -> [#enumerating].
+ [#(Context failPrimitiveWith:)] -> [#'system simulation'].
+ [#(Context isPrimFailToken:)] -> [#private].
+ [#(Context send:to:with:lookupIn:)] -> [#controlling].
+ [#(Context isPrimFailToken:)] -> [#private].
+ [#(Context send:to:with:lookupIn:)] -> [#controlling].
+ [#(CompiledMethod class headerFlagForEncoder:)]
+ -> [#'method encoding'].
+ [#(CompiledMethod class installPrimaryBytecodeSet:)]
+ -> [#'class initialization'].
+ [#(CompiledMethod class installSecondaryBytecodeSet:)]
+ -> [#'class initialization'].
+ [#(EncoderForV3PlusClosures genCallPrimitive:)]
+ -> [#'bytecode generation'].
+ [#(EncoderForV3PlusClosures class callPrimitiveCode)]
+ -> [#'bytecode decoding'].
+ [#(Context failPrimitiveWith:)] -> [#'system simulation'].
+ [#(Context class allInstances)] -> [#enumerating].
+ [#(Context class allInstancesDo:)] -> [#enumerating].
+ [#(SmallInteger asCharacter)] -> [#converting].
+ [#(SmalltalkImage growMemoryByAtLeast:)] -> [#'memory space'].
+ [#(SmalltalkImage maxIdentityHash)] -> [#'system attributes'].
+ [#(SystemDictionary growMemoryByAtLeast:)] -> [#'memory space'].
+ [#(SystemDictionary maxIdentityHash)] -> [#'system attributes'].
+ [#(SystemDictionary setGCParameters)] -> [#'snapshot and quit'].
+ [#(SystemNavigation allObjects)] -> [#query].
+ [#(SystemNavigation allObjectsOrNil)] -> [#query].
+ }
+ otherwise:
+ [Transcript nextPutAll: className.
+ isMeta ifTrue: [Transcript nextPutAll: ' class'].
+ Transcript nextPutAll: '>>'; store: selector; nextPutAll: ' is unclassified'; cr; flush.
+ ^Categorizer default]!
Item was changed:
+ SpurBootstrapSqueakFamilyPrototypes subclass: #SpurBootstrapSqueak43Prototypes
- SpurBootstrapPrototypes subclass: #SpurBootstrapSqueak43Prototypes
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Cog-Bootstrapping'!
Item was changed:
----- Method: SpurBootstrapSqueak43Prototypes>>InstructionStreamPROTOTYPEinterpretExtension:in:for: (in category 'method prototypes') -----
InstructionStreamPROTOTYPEinterpretExtension: offset in: method for: client
^self interpretV3ClosuresExtension: offset in: method for: client!
Item was added:
+ SpurBootstrapPrototypes subclass: #SpurBootstrapSqueakFamilyPrototypes
+ instanceVariableNames: ''
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Cog-Bootstrapping'!
Item was added:
+ ----- Method: SpurBootstrapSqueakFamilyPrototypes>>ClassBuilderPROTOTYPEcomputeFormat:instSize:forSuper:ccIndex: (in category 'method prototypes') -----
+ ClassBuilderPROTOTYPEcomputeFormat: type instSize: newInstSize forSuper: newSuper ccIndex: ccIndex
+ "Compute the new format for making oldClass a subclass of newSuper.
+ Answer the format or nil if there is any problem."
+ | instSize isVar isWords isPointers isWeak |
+ type == #compiledMethod ifTrue:
+ [newInstSize > 0 ifTrue:
+ [self error: 'A compiled method class cannot have named instance variables'.
+ ^nil].
+ ^CompiledMethod format].
+ instSize := newInstSize + (newSuper ifNil:[0] ifNotNil:[newSuper instSize]).
+ instSize > 65535 ifTrue:
+ [self error: 'Class has too many instance variables (', instSize printString,')'.
+ ^nil].
+ type == #normal ifTrue:[isVar := isWeak := false. isWords := isPointers := true].
+ type == #bytes ifTrue:[isVar := true. isWords := isPointers := isWeak := false].
+ type == #words ifTrue:[isVar := isWords := true. isPointers := isWeak := false].
+ type == #variable ifTrue:[isVar := isPointers := isWords := true. isWeak := false].
+ type == #weak ifTrue:[isVar := isWeak := isWords := isPointers := true].
+ type == #ephemeron ifTrue:[isVar := false. isWeak := isWords := isPointers := true].
+ type == #immediate ifTrue:[isVar := isWeak := isPointers := false. isWords := true].
+ (isPointers not and: [instSize > 0]) ifTrue:
+ [self error: 'A non-pointer class cannot have named instance variables'.
+ ^nil].
+ ^self format: instSize variable: isVar words: isWords pointers: isPointers weak: isWeak!
Item was added:
+ ----- Method: SpurBootstrapSqueakFamilyPrototypes>>ClassBuilderPROTOTYPEformat:variable:words:pointers:weak: (in category 'method prototypes') -----
+ ClassBuilderPROTOTYPEformat: nInstVars variable: isVar words: is32BitWords pointers: isPointers weak: isWeak
+ "Compute the format for the given instance specfication.
+ Above Cog Spur the class format is
+ <5 bits inst spec><16 bits inst size>
+ where the 5-bit inst spec is
+ 0 = 0 sized objects (UndefinedObject True False et al)
+ 1 = non-indexable objects with inst vars (Point et al)
+ 2 = indexable objects with no inst vars (Array et al)
+ 3 = indexable objects with inst vars (MethodContext AdditionalMethodState et al)
+ 4 = weak indexable objects with inst vars (WeakArray et al)
+ 5 = weak non-indexable objects with inst vars (ephemerons) (Ephemeron)
+ 6 = unused
+ 7 = immediates (SmallInteger, Character)
+ 8 = unused
+ 9 = reserved for 64-bit indexable
+ 10-11 = 32-bit indexable (Bitmap)
+ 12-15 = 16-bit indexable
+ 16-23 = 8-bit indexable
+ 24-31 = compiled methods (CompiledMethod)"
+ | instSpec |
+ instSpec := isWeak
+ ifTrue:
+ [isVar
+ ifTrue: [4]
+ ifFalse: [5]]
+ ifFalse:
+ [isPointers
+ ifTrue:
+ [isVar
+ ifTrue: [nInstVars > 0 ifTrue: [3] ifFalse: [2]]
+ ifFalse: [nInstVars > 0 ifTrue: [1] ifFalse: [0]]]
+ ifFalse:
+ [isVar
+ ifTrue: [is32BitWords ifTrue: [10] ifFalse: [16]]
+ ifFalse: [7]]].
+ ^(instSpec bitShift: 16) + nInstVars!
Item was added:
+ ----- Method: SpurBootstrapSqueakFamilyPrototypes>>ClassBuilderPROTOTYPEsuperclass:immediateSubclass:instanceVariableNames:classVariableNames:poolDictionaries:category: (in category 'method prototypes') -----
+ ClassBuilderPROTOTYPEsuperclass: aClass
+ immediateSubclass: t instanceVariableNames: f
+ classVariableNames: d poolDictionaries: s category: cat
+ "This is the standard initialization message for creating a
+ new immediate class as a subclass of an existing class."
+ | env |
+ aClass instSize > 0
+ ifTrue: [^self error: 'cannot make an immediate subclass of a class with named fields'].
+ aClass isVariable
+ ifTrue: [^self error: 'cannot make an immediate subclass of a class with indexed instance variables'].
+ aClass isPointers
+ ifFalse: [^self error: 'cannot make an immediate subclass of a class without pointer fields'].
+ "Cope with pre-environment and environment versions. Simplify asap."
+ env := (Smalltalk classNamed: #EnvironmentRequest)
+ ifNil: [aClass environment]
+ ifNotNil: [:erc| erc signal ifNil: [aClass environment]].
+ ^self
+ name: t
+ inEnvironment: env
+ subclassOf: aClass
+ type: #immediate
+ instanceVariableNames: f
+ classVariableNames: d
+ poolDictionaries: s
+ category: cat!
Item was added:
+ ----- Method: SpurBootstrapSqueakFamilyPrototypes>>ClassBuilderPROTOTYPEupdate:to: (in category 'method prototypes') -----
+ ClassBuilderPROTOTYPEupdate: oldClass to: newClass
+ "Convert oldClass, all its instances and possibly its meta class into newClass,
+ instances of newClass and possibly its meta class. The process is surprisingly
+ simple in its implementation and surprisingly complex in its nuances and potentially
+ bad side effects.
+ We can rely on two assumptions (which are critical):
+ #1: The method #updateInstancesFrom: will not create any lasting pointers to
+ 'old' instances ('old' is quote on quote since #updateInstancesFrom: will do
+ a become of the old vs. the new instances and therefore it will not create
+ pointers to *new* instances before the #become: which are *old* afterwards)
+ #2: The non-preemptive execution of the critical piece of code guarantees that
+ nobody can get a hold by 'other means' (such as process interruption and
+ reflection) on the old instances.
+ Given the above two, we know that after #updateInstancesFrom: there are no pointers
+ to any old instances. After the forwarding become there will be no pointers to the old
+ class or meta class either.
+ Andreas Raab, 2/27/2003 23:42"
+ | meta |
+ meta := oldClass isMeta.
+ "Note: Everything from here on will run without the ability to get interrupted
+ to prevent any other process to create new instances of the old class."
+ ["Note: The following removal may look somewhat obscure and needs an explanation.
+ When we mutate the class hierarchy we create new classes for any existing subclass.
+ So it may look as if we don't have to remove the old class from its superclass. However,
+ at the top of the hierarchy (the first class we reshape) that superclass itself is not newly
+ created so therefore it will hold both the oldClass and newClass in its (obsolete or not)
+ subclasses. Since the #become: below will transparently replace the pointers to oldClass
+ with newClass the superclass would have newClass in its subclasses TWICE. With rather
+ unclear effects if we consider that we may convert the meta-class hierarchy itself (which
+ is derived from the non-meta class hierarchy).
+ Due to this problem ALL classes are removed from their superclass just prior to converting
+ them. Here, breaking the superclass/subclass invariant really doesn't matter since we will
+ effectively remove the oldClass (becomeForward:) just a few lines below."
+
+ oldClass superclass removeSubclass: oldClass.
+ oldClass superclass removeObsoleteSubclass: oldClass.
+
+ "make sure that the VM cache is clean"
+ oldClass methodDict do: [:cm | cm flushCache].
+
+ "Convert the instances of oldClass into instances of newClass"
+ newClass updateInstancesFrom: oldClass.
+
+ meta
+ ifTrue:
+ [oldClass becomeForward: newClass.
+ oldClass updateMethodBindingsTo: oldClass binding]
+ ifFalse:
+ [{oldClass. oldClass class} elementsForwardIdentityTo: {newClass. newClass class}.
+ oldClass updateMethodBindingsTo: oldClass binding.
+ oldClass class updateMethodBindingsTo: oldClass class binding].
+
+ "eem 5/31/2014 07:22 At this point there used to be a garbage collect whose purpose was
+ to ensure no old instances existed after the becomeForward:. Without the GC it was possible
+ to resurrect old instances using e.g. allInstancesDo:. This was because the becomeForward:
+ updated references from the old objects to new objects but didn't destroy the old objects.
+ But as of late 2013/early 2014 becomeForward: has been modified to free all the old objects."]
+ valueUnpreemptively!
Item was added:
+ ----- Method: SpurBootstrapSqueakFamilyPrototypes>>InstructionPrinterPROTOTYPEcallPrimitive: (in category 'method prototypes') -----
+ InstructionPrinterPROTOTYPEcallPrimitive: index
+ "Print the callPrimitive."
+
+ self print: 'callPrimtive: ' , index printString!
Item was changed:
+ SpurBootstrapSqueakFamilyPrototypes subclass: #SpurBootstrapSqueakPrototypes
- SpurBootstrapPrototypes subclass: #SpurBootstrapSqueakPrototypes
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Cog-Bootstrapping'!
Item was changed:
----- Method: SpurBootstrapSqueakPrototypes>>BehaviorPROTOTYPEidentityHash (in category 'method prototypes') -----
BehaviorPROTOTYPEidentityHash
"Answer a SmallInteger whose value is related to the receiver's identity.
Behavior implements identityHash to allow the VM to use an object representation which
does not include a direct reference to an object's class in an object. If the VM is using
this implementation then classes are held in a class table and instances contain the index
of their class in the table. A class's class table index is its identityHash so that an instance
can be created without searching the table for a class's index. The VM uses this primitive
to enter the class into the class table, assigning its identityHash with an as yet unused
class table index. If this primitive fails it means that the class table is full. In Spur as of
2014 there are 22 bits of classTable index and 22 bits of identityHash per object.
Primitive. Essential. Do not override. See Object documentation whatIsAPrimitive."
<primitive: 175>
self primitiveFailed!
Item was changed:
----- Method: SpurBootstrapSqueakPrototypes>>CharacterPROTOTYPEclone (in category 'method prototypes') -----
CharacterPROTOTYPEclone
"Answer the receiver, because Characters are unique."
^self!
Item was changed:
----- Method: SpurBootstrapSqueakPrototypes>>ClassPROTOTYPEimmediateSubclass:instanceVariableNames:classVariableNames:poolDictionaries:category: (in category 'method prototypes') -----
ClassPROTOTYPEimmediateSubclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat
"This is the standard initialization message for creating a new
immediate class as a subclass of an existing class (the receiver)."
^ClassBuilder new
superclass: self
immediateSubclass: t
instanceVariableNames: f
classVariableNames: d
poolDictionaries: s
category: cat!
Item was changed:
----- Method: SpurBootstrapSqueakPrototypes>>ContextPartPROTOTYPEsend:to:with:super: (in category 'method prototypes') -----
ContextPartPROTOTYPEsend: selector to: rcvr with: arguments super: superFlag
"Simulate the action of sending a message with selector arguments
to rcvr. The argument, superFlag, tells whether the receiver of the
message was specified with 'super' in the source method."
^self send: selector
to: rcvr
with: arguments
lookupIn: (superFlag
ifTrue: [self method methodClassAssociation value superclass]
ifFalse: [self objectClass: rcvr])!
Item was changed:
----- Method: SpurBootstrapSqueakPrototypes>>ContextPartPROTOTYPEtryNamedPrimitiveIn:for:withArgs: (in category 'method prototypes') -----
ContextPartPROTOTYPEtryNamedPrimitiveIn: aCompiledMethod for: aReceiver withArgs: arguments
"Invoke the named primitive for aCompiledMethod, answering its result, or,
if the primiitve fails, answering the error code."
<primitive: 218 error: ec>
ec ifNotNil:
["If ec is an integer other than -1 there was a problem with primitive 218,
not with the external primitive itself. -1 indicates a generic failure (where
ec should be nil) but ec = nil means primitive 218 is not implemented. So
interpret -1 to mean the external primitive failed with a nil error code."
ec isInteger ifTrue:
[ec = -1
ifTrue: [ec := nil]
ifFalse: [self primitiveFailed]]].
^self class primitiveFailTokenFor: ec!
Item was changed:
----- Method: SpurBootstrapSqueakPrototypes>>IntegerclassPROTOTYPEinitialize (in category 'method prototypes') -----
IntegerclassPROTOTYPEinitialize
"Integer initialize"
self initializeLowBitPerByteTable!
Item was changed:
----- Method: SpurBootstrapSqueakPrototypes>>MethodContextclassPROTOTYPEallInstances (in category 'method prototypes') -----
MethodContextclassPROTOTYPEallInstances
"Answer all instances of the receiver."
<primitive: 177>
"The primitive can fail because memory is low. If so, fall back on the old
enumeration code, which gives the system a chance to GC and/or grow.
Because aBlock might change the class of inst (for example, using become:),
it is essential to compute next before aBlock value: inst.
Only count until thisContext since this context has been created only to
compute the existing instances."
| inst insts next |
insts := WriteStream on: (Array new: 64).
inst := self someInstance.
[inst == thisContext or: [inst == nil]] whileFalse:
[next := inst nextInstance.
insts nextPut: inst.
inst := next].
^insts contents!
Item was changed:
----- Method: SpurBootstrapSqueakPrototypes>>MethodContextclassPROTOTYPEallInstancesDo: (in category 'method prototypes') -----
MethodContextclassPROTOTYPEallInstancesDo: aBlock
"Evaluate aBlock with each of the current instances of the receiver."
| instances inst next |
instances := self allInstancesOrNil.
instances ifNotNil:
[instances do: aBlock.
^self].
"allInstancesOrNil can fail because memory is low. If so, fall back on the old
enumeration code. Because aBlock might change the class of inst (for example,
using become:), it is essential to compute next before aBlock value: inst.
Only count until thisContext since evaluation of aBlock will create new contexts."
inst := self someInstance.
[inst == thisContext or: [inst == nil]] whileFalse:
[next := inst nextInstance.
aBlock value: inst.
inst := next]!
Item was changed:
----- Method: SpurBootstrapSqueakPrototypes>>ProtoObjectPROTOTYPEscaledIdentityHash (in category 'method prototypes') -----
ProtoObjectPROTOTYPEscaledIdentityHash
"For identityHash values returned by primitive 75, answer
such values times 2^8. Otherwise, match the existing
identityHash implementation"
^self identityHash * 256 "bitShift: 8"!
Item was changed:
----- Method: SpurBootstrapSqueakPrototypes>>SmalltalkImagePROTOTYPEsetGCParameters (in category 'method prototypes') -----
SmalltalkImagePROTOTYPEsetGCParameters
"Adjust the VM's default GC parameters to avoid too much tenuring.
Maybe this should be left to the VM?"
| proportion edenSize survivorSize averageObjectSize numObjects |
proportion := 0.9. "tenure when 90% of pastSpace is full"
edenSize := SmalltalkImage current vmParameterAt: 44.
survivorSize := edenSize / 5.0. "David's paper uses 140Kb eden + 2 x 28kb survivor spaces; Spur uses the same ratios :-)"
averageObjectSize := 8 * self wordSize. "a good approximation"
numObjects := (proportion * survivorSize / averageObjectSize) rounded.
SmalltalkImage current vmParameterAt: 6 put: numObjects "tenure when more than this many objects survive the GC"!
Item was changed:
----- Method: SpurBootstrapSqueakPrototypes>>SystemDictionaryPROTOTYPEsetGCParameters (in category 'method prototypes') -----
SystemDictionaryPROTOTYPEsetGCParameters
"Adjust the VM's default GC parameters to avoid too much tenuring.
Maybe this should be left to the VM?"
| proportion edenSize survivorSize averageObjectSize numObjects |
proportion := 0.9. "tenure when 90% of pastSpace is full"
edenSize := SmalltalkImage current vmParameterAt: 44.
survivorSize := edenSize / 5.0. "David's paper uses 140Kb eden + 2 x 28kb survivor spaces; Spur uses the same ratios :-)"
averageObjectSize := 8 * self wordSize. "a good approximation"
numObjects := (proportion * survivorSize / averageObjectSize) rounded.
SmalltalkImage current vmParameterAt: 6 put: numObjects "tenure when more than this many objects survive the GC"!
1
0