Eliot Miranda uploaded a new version of Cog to project VM Maker:
http://source.squeak.org/VMMaker/Cog-eem.109.mcz
==================== Summary ====================
Name: Cog-eem.109
Author: eem
Time: 9 October 2013, 11:13:10.197 am
UUID: 8caa23c1-026c-4dde-948a-670395190d2a
Ancestors: Cog-eem.108
Set image flags in sim used to writeSnapshotOfTransformedImage
=============== Diff against Cog-eem.108 ===============
Item was changed:
----- Method: SpurBootstrap>>writeSnapshotOfTransformedImage (in category 'testing') -----
writeSnapshotOfTransformedImage
"The bootstrapped image typically contains a few big free chunks and one huge free chunk.
Test snapshot writing and loading by turning the largest non-huge chunks into segment bridges
and saving."
| heap sizes counts barriers sim |
heap := TransformedImage veryDeepCopy.
sim := StackInterpreterSimulator onObjectMemory: heap.
heap coInterpreter: sim.
+ sim initializeInterpreter: 0;
+ setImageHeaderFlagsFrom: ImageHeaderFlags.
- sim initializeInterpreter: 0.
sizes := Bag new.
heap allObjectsInFreeTree: (heap freeLists at: 0) do:
[:f|
sizes add: (heap bytesInObject: f)].
counts := sizes sortedCounts.
self assert: counts last key = 1. "1 huge chunk"
self assert: ((counts at: counts size - 1) key > 2
and: [(counts at: counts size - 1) value > 1024]).
barriers := (1 to: (counts at: counts size - 1) key) collect:
[:ign| heap allocateOldSpaceChunkOfExactlyBytes: (counts at: counts size - 1) value].
heap segmentManager initializeFromFreeChunks: (barriers sort collect: [:b| heap objectStartingAt: b]).
sim imageName: 'spur.image'.
sim writeImageFileIO!
1
0
Eliot Miranda uploaded a new version of VMMaker to project VM Maker:
http://source.squeak.org/VMMaker/VMMaker.oscog-eem.444.mcz
==================== Summary ====================
Name: VMMaker.oscog-eem.444
Author: eem
Time: 9 October 2013, 9:11:03.947 am
UUID: 1e751c1f-c5c0-4c30-85f1-5f8ef8bf71e1
Ancestors: VMMaker.oscog-eem.443
Make the simulators write snapshots by deleting their
primitiveImageName implementations which only get, not set,
and implementing imageName[Get|Put]:Length: & imageNameSize.
Make SecurityPlugin>>secCanRenameImage answer something
sensible during simulation.
Fix bugs in LittleEndianBitmap.
Fix objectHeader: in the CogMethodSurrogates (needed for code
compaction to work).
Hack NewObjectMemorySimulator>>storePointerUnchecked:ofObject:withValue:
to disable the check when nilling contexts in snapshot.
=============== Diff against VMMaker.oscog-eem.443 ===============
Item was removed:
- ----- Method: CogMethodSurrogate32>>objectHeader: (in category 'accessing') -----
- objectHeader: aValue
- ^memory
- unsignedLongAt: address + 1
- put: aValue!
Item was removed:
- ----- Method: CogMethodSurrogate64>>objectHeader: (in category 'accessing') -----
- objectHeader: aValue
- ^memory
- unsignedLongLongAt: address + 1
- put: aValue!
Item was added:
+ ----- Method: CogVMSimulator>>dispatchMappedPluginEntry: (in category 'plugin primitive support') -----
+ dispatchMappedPluginEntry: n
+ ^(mappedPluginEntries at: n) first
+ perform: (mappedPluginEntries at: n) second!
Item was added:
+ ----- Method: CogVMSimulator>>imageNameGet:Length: (in category 'file primitives') -----
+ imageNameGet: p Length: sz
+ 1 to: sz do:
+ [:i |
+ objectMemory
+ byteAt: p + i - 1
+ put: (imageName at: i) asInteger]!
Item was added:
+ ----- Method: CogVMSimulator>>imageNamePut:Length: (in category 'file primitives') -----
+ imageNamePut: p Length: sz
+ | newName |
+ newName := ByteString new: sz.
+ 1 to: sz do:
+ [:i |
+ newName
+ at: i
+ put: (Character value: (objectMemory byteAt: p + i - 1))].
+ imageName := newName!
Item was added:
+ ----- Method: CogVMSimulator>>imageNameSize (in category 'file primitives') -----
+ imageNameSize
+ ^imageName size!
Item was removed:
- ----- Method: CogVMSimulator>>primitiveImageName (in category 'file primitives') -----
- primitiveImageName
- "Note: For now, this only implements getting, not setting, the image file name."
- | result imageNameSize |
- self pop: 1.
- imageNameSize := imageName size.
- result := objectMemory instantiateClass: (objectMemory splObj: ClassByteString)
- indexableSize: imageNameSize.
- 1 to: imageNameSize do:
- [:i | objectMemory storeByte: i-1 ofObject: result
- withValue: (imageName at: i) asciiValue].
- self push: result.!
Item was added:
+ ----- Method: CogVMSimulator>>writeImageFileIO (in category 'image save/restore') -----
+ writeImageFileIO
+ "Write the image to a file as an image snapshot."
+
+ | headerSize file |
+ BytesPerWord = 4 ifFalse: [self error: 'Not rewritten for 64 bits yet'].
+ headerSize := 64.
+
+ (file := FileStream fileNamed: imageName) ifNil:
+ [self primitiveFail.
+ ^nil].
+ [
+ file binary.
+
+ {
+ self imageFormatVersion.
+ headerSize.
+ objectMemory imageSizeToWrite.
+ objectMemory baseAddressOfImage.
+ objectMemory specialObjectsOop.
+ objectMemory lastHash.
+ self ioScreenSize.
+ self getImageHeaderFlags.
+ extraVMMemory
+ }
+ do: [:long | self putLong: long toFile: file].
+
+ { desiredNumStackPages. self unknownShortOrCodeSizeInKs } do:
+ [:short| self putShort: short toFile: file].
+
+ self putLong: desiredEdenBytes toFile: file.
+
+ { maxExtSemTabSizeSet ifTrue: [self ioGetMaxExtSemTableSize] ifFalse: [0]. 0 } do:
+ [:short| self putShort: short toFile: file].
+
+ objectMemory hasSpurMemoryManagerAPI
+ ifTrue:
+ [| bytesWritten |
+ self putLong: objectMemory firstSegmentBytes toFile: file."Pad the rest of the header."
+ 3 timesRepeat: [self putLong: 0 toFile: file].
+
+ "Position the file after the header."
+ file position: headerSize.
+ bytesWritten := objectMemory segmentManager writeImageToFile: 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 removed:
- ----- Method: CogVMSimulator>>writeImageFileIO: (in category 'image save/restore') -----
- writeImageFileIO: numberOfBytesToWrite
- "Actually emit the first numberOfBytesToWrite object memory bytes onto the snapshot."
-
- | headerSize file |
- BytesPerWord = 4 ifFalse: [self error: 'Not rewritten for 64 bits yet'].
- headerSize := 64.
-
- [
- file := FileStream fileNamed: imageName.
- file == nil ifTrue:
- [self primitiveFail.
- ^nil].
- file binary.
-
- {
- self imageFormatVersion.
- headerSize.
- numberOfBytesToWrite.
- objectMemory startOfMemory.
- (objectMemory specialObjectsOop).
- (objectMemory lastHash).
- self ioScreenSize.
- self getImageHeaderFlags.
- extraVMMemory
- }
- do: [:long | self putLong: long toFile: file].
-
- { desiredNumStackPages. self unknownShortOrCodeSizeInKs } do:
- [:short| self putShort: short toFile: file].
-
- self putLong: desiredEdenBytes toFile: file.
-
- { maxExtSemTabSizeSet ifTrue: [self ioGetMaxExtSemTableSize] ifFalse: [0]. 0 } do:
- [:short| self putShort: short toFile: file].
-
- "Pad the rest of the header."
- 4 timesRepeat: [self putLong: 0 toFile: file].
-
- "Position the file after the header."
- file position: headerSize.
-
- "Write the object memory."
- objectMemory startOfMemory // 4 + 1
- to: numberOfBytesToWrite // 4
- do: [:index |
- self
- putLong: (objectMemory memory at: index)
- toFile: file].
-
- self success: true
- ]
- ensure: [file ifNotNil: [file close]]!
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]].
- sCRIfn ~= 0 ifTrue:[okToRename := self cCode:' ((sqInt (*)(void))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 + 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 + BaseHeaderSize) Length: sz.
self pop: 1. "rcvr"
self push: s.
]!
Item was changed:
----- Method: LittleEndianBitmap>>byteAt:put: (in category 'accessing') -----
byteAt: byteAddress put: byte
+ "Insert a byte into a Bitmap (little-endian version). N.B. SIgnedness will be lost since byteAt: ansers non-negative values."
+ | value longWord shift lowBits longAddr |
- "Insert a byte into a Bitmap (little-endian version)"
- | longWord shift lowBits longAddr |
(byte < 0 or:[byte > 255]) ifTrue:[^self errorImproperStore].
+ value := byte < 0
+ ifTrue: [byte < 128 ifTrue:
+ [self errorImproperStore].
+ 16rFF bitAnd: byte]
+ ifFalse: [16rFF < byte ifTrue:
+ [self errorImproperStore].
+ byte].
lowBits := byteAddress - 1 bitAnd: 3.
longWord := self at: (longAddr := (byteAddress - 1 - lowBits) // 4 + 1).
shift := lowBits * 8.
longWord := longWord
- (longWord bitAnd: (16rFF bitShift: shift))
+ + (value bitShift: shift).
- + (byte bitShift: shift).
self at: longAddr put: longWord.
^byte!
Item was added:
+ ----- Method: LittleEndianBitmap>>longAt:put: (in category 'accessing') -----
+ longAt: byteIndex put: aValue
+ "Compatibility with the ByteArray method of the same name."
+ | lowBits wordIndex value mask |
+ lowBits := byteIndex - 1 bitAnd: 3.
+ wordIndex := byteIndex - 1 // 4 + 1.
+ value := aValue < 0
+ ifTrue: [16rFFFFFFFF bitAnd: aValue]
+ ifFalse: [16rFFFFFFFF < aValue ifTrue:
+ [self errorImproperStore].
+ aValue].
+ lowBits = 0 ifTrue:
+ [self at: wordIndex put: value.
+ ^aValue].
+ mask := 16rFFFFFFFF bitAnd: 16rFFFFFFFF << (lowBits * 8).
+ self at: wordIndex put: (((self at: wordIndex) bitAnd: mask bitInvert) bitXor: (value << (lowBits * 8) bitAnd: mask)).
+ self at: wordIndex + 1 put: (((self at: wordIndex + 1) bitAnd: mask) bitXor: (value >> (4 - lowBits * 8) bitAnd: mask bitInvert)).
+ ^aValue
+
+ "(1 to: 8) collect:
+ [:ba| | bm |
+ bm := LittleEndianBitmap new: 4.
+ bm at: 1 put: 16r55555555.
+ bm at: 2 put: 16rAAAAAAAA.
+ bm longAt: ba put: 16r04030201.
+ { (bm at: 1) hex. (bm at: 2) hex }]"!
Item was changed:
----- Method: LittleEndianBitmap>>longAt:put:bigEndian: (in category 'accessing') -----
longAt: byteIndex put: aValue bigEndian: bigEndian
"Compatibility with the ByteArray method of the same name."
| lowBits wordIndex value mask |
lowBits := byteIndex - 1 bitAnd: 3.
wordIndex := byteIndex - 1 // 4 + 1.
value := aValue < 0
+ ifTrue: [16rFFFFFFFF bitAnd: aValue]
- ifTrue: [16rFFFFFFFF bitAnd: value]
ifFalse: [16rFFFFFFFF < aValue ifTrue:
[self errorImproperStore].
aValue].
bigEndian ifTrue:
[value := (value >> 24 bitAnd: 16rFF)
+ (value >> 8 bitAnd: 16rFF00)
+ ((value bitAnd: 16rFF00) << 8)
+ ((value bitAnd: 16rFF) << 24)].
lowBits = 0 ifTrue:
[self at: wordIndex put: value.
^aValue].
mask := 16rFFFFFFFF bitAnd: 16rFFFFFFFF << (lowBits * 8).
self at: wordIndex put: (((self at: wordIndex) bitAnd: mask bitInvert) bitXor: (value << (lowBits * 8) bitAnd: mask)).
self at: wordIndex + 1 put: (((self at: wordIndex + 1) bitAnd: mask) bitXor: (value >> (4 - lowBits * 8) bitAnd: mask bitInvert)).
^aValue
"(1 to: 8) collect:
[:ba| | bm |
bm := LittleEndianBitmap new: 4.
bm at: 1 put: 16r55555555.
bm at: 2 put: 16rAAAAAAAA.
bm longAt: ba put: 16r04030201 bigEndian: false.
{ (bm at: 1) hex. (bm at: 2) hex }]"
"(1 to: 8) collect:
[:ba| | bm |
bm := LittleEndianBitmap new: 4.
bm at: 1 put: 16r55555555.
bm at: 2 put: 16rAAAAAAAA.
bm longAt: ba put: 16r01020304 bigEndian: true.
{ (bm at: 1) hex. (bm at: 2) hex }]"!
Item was added:
+ ----- Method: NewObjectMemory>>baseAddressOfImage (in category 'snapshot') -----
+ baseAddressOfImage
+ "Answer the base address of the image data written to a sapshot."
+ ^self startOfMemory!
Item was added:
+ ----- Method: NewObjectMemory>>imageSizeToWrite (in category 'snapshot') -----
+ imageSizeToWrite
+ "Answer the number of bytes that will be written to
+ the image file in a snapshot, excluding the header."
+ ^freeStart - self startOfMemory!
Item was added:
+ ----- Method: NewObjectMemorySimulator>>heapMapAtWord: (in category 'heap map') -----
+ heapMapAtWord: address
+ ^heapMap heapMapAtWord: address!
Item was changed:
----- Method: NewObjectMemorySimulator>>storePointerUnchecked:ofObject:withValue: (in category 'interpreter access') -----
storePointerUnchecked: index 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.
+ thisContext sender selector ~~ #snapshotCleanUp ifTrue:
+ [self assert: ((fmt <= self lastPointerFormat or: [fmt >= self firstCompiledMethodFormat])
+ and: [index >= 0 and: [index < (self lengthOf: oop baseHeader: hdr format: fmt)]])].
- self assert: ((fmt <= self lastPointerFormat or: [fmt >= self firstCompiledMethodFormat])
- and: [index >= 0 and: [index < (self lengthOf: oop baseHeader: hdr format: fmt)]]).
^super storePointerUnchecked: index ofObject: oop withValue: valuePointer!
Item was changed:
----- Method: SecurityPlugin>>secCanRenameImage (in category 'exported functions') -----
secCanRenameImage
<export: true>
+ ^self cCode: [self ioCanRenameImage] inSmalltalk: [true]!
- ^self cCode: 'ioCanRenameImage()'!
Item was changed:
----- Method: StackInterpreter>>abstractDetailedSymbolicMethod: (in category 'debug support') -----
abstractDetailedSymbolicMethod: aMethod
<doNotGenerate>
| ts prim |
(ts := self transcript) ensureCr.
(prim := self primitiveIndexOf: aMethod) > 0 ifTrue:
[ts nextPutAll: '<primitive: '; print: prim; nextPut: $>.
(self isQuickPrimitiveIndex: prim) ifTrue:
[ts nextPutAll: ' quick method'; cr; flush.
^self].
ts cr].
(RelativeDetailedInstructionPrinter
on: (VMCompiledMethodProxy new
for: aMethod
coInterpreter: self
objectMemory: objectMemory))
indent: 0;
printInstructionsOn: ts.
ts flush!
Item was changed:
----- Method: StackInterpreter>>activateNewMethod (in category 'message sending') -----
activateNewMethod
| methodHeader |
methodHeader := self justActivateNewMethod.
"Now check for stack overflow or an event (interrupt, must scavenge, etc)."
stackPointer < stackLimit ifTrue:
[self handleStackOverflowOrEventAllowContextSwitch: (self canContextSwitchIfActivating: newMethod header: methodHeader)]!
Item was removed:
- ----- Method: StackInterpreter>>addFirstLink:toList: (in category 'process primitive support') -----
- addFirstLink: proc toList: aList
- "Add the given process to the front of the given linked list
- and set the backpointer of process to its new list."
- | firstLink |
- self assert: (objectMemory fetchPointer: NextLinkIndex ofObject: proc) = objectMemory nilObject.
- firstLink := objectMemory fetchPointer: FirstLinkIndex ofObject: aList.
- self assert: firstLink ~= proc.
- objectMemory storePointer: FirstLinkIndex ofObject: aList withValue: proc.
- firstLink = objectMemory nilObject "a.k.a. (self isEmptyList: aList)"
- ifTrue: [objectMemory storePointer: LastLinkIndex ofObject: aList withValue: proc]
- ifFalse: [objectMemory storePointer: NextLinkIndex ofObject: proc withValue: firstLink].
- objectMemory storePointer: MyListIndex ofObject: proc withValue: aList!
Item was added:
+ ----- Method: StackInterpreter>>addFirstLink:toList: (in category 'process primitive support') -----
+ addFirstLink: proc toList: aList
+ "Add the given process to the front of the given linked list
+ and set the backpointer of process to its new list."
+ | firstLink |
+ self assert: (objectMemory fetchPointer: NextLinkIndex ofObject: proc) = objectMemory nilObject.
+ firstLink := objectMemory fetchPointer: FirstLinkIndex ofObject: aList.
+ self assert: firstLink ~= proc.
+ objectMemory storePointer: FirstLinkIndex ofObject: aList withValue: proc.
+ firstLink = objectMemory nilObject "a.k.a. (self isEmptyList: aList)"
+ ifTrue: [objectMemory storePointer: LastLinkIndex ofObject: aList withValue: proc]
+ ifFalse: [objectMemory storePointer: NextLinkIndex ofObject: proc withValue: firstLink].
+ objectMemory storePointer: MyListIndex ofObject: proc withValue: aList!
Item was changed:
----- Method: StackInterpreter>>addressCouldBeClassObj: (in category 'debug support') -----
addressCouldBeClassObj: maybeClassObj
"Answer if maybeClassObj looks like a class object"
<inline: false>
^(objectMemory addressCouldBeObj: maybeClassObj)
and: [self objCouldBeClassObj: maybeClassObj]!
Item was changed:
----- Method: StackInterpreter>>allocateMemory:minimum:imageFile:headerSize: (in category 'image save/restore') -----
allocateMemory: heapSize minimum: minimumMemory imageFile: fileStream headerSize: headerSize
"Translate to C function call with (case sensitive) camelCase. The purpose of this
method is to document the translation.
The default implementation is sqAllocateMemory(minimumMemory, heapSize). This may
be redefined to make use of the image file and header size parameters for efficient
implementation with mmap().
See CCodeGenerator>>writeDefaultMacrosOn: which specifies a default implementation."
<inline: true>
<returnTypeC: #'char *'>
<var: #fileStream type: #sqImageFile>
^self pointerForOop: (self
allocateMemory: heapSize
Minimum: minimumMemory
ImageFile: fileStream
HeaderSize: headerSize)!
Item was changed:
----- Method: StackInterpreter>>argumentCountOf: (in category 'compiled methods') -----
argumentCountOf: methodPointer
<api>
^self argumentCountOfMethodHeader: (self headerOf: methodPointer)!
Item was changed:
----- Method: StackInterpreter>>argumentCountOfClosure: (in category 'internal interpreter access') -----
argumentCountOfClosure: closurePointer
<api> "for Cogit"
<inline: true>
^self quickFetchInteger: ClosureNumArgsIndex ofObject: closurePointer!
Item was changed:
----- Method: StackInterpreter>>argumentCountOfMethodHeader: (in category 'compiled methods') -----
argumentCountOfMethodHeader: header
<api>
^header >> 25 bitAnd: 16r0F!
Item was changed:
----- Method: StackInterpreter>>assertValidExecutionPointe:r:s: (in category 'debug support') -----
assertValidExecutionPointe: lip r: lifp s: lisp
<inline: true>
<var: #lip type: #'usqInt'>
<var: #lifp type: #'char *'>
<var: #lisp type: #'char *'>
self assertValidExecutionPointe: lip r: lifp s: lisp imbar: (self isMachineCodeFrame: lifp) not line: #'__LINE__'!
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) < 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>>assertValidExecutionPointers (in category 'debug support') -----
assertValidExecutionPointers
<doNotGenerate> "simulator only"
self assertValidExecutionPointe: localIP r: localFP s: localSP!
Item was changed:
----- Method: StackInterpreter>>bereaveAllMarriedContexts (in category 'frame access') -----
bereaveAllMarriedContexts
"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.
Thanks to Greg Nuyens for this idea."
<asmLabel: false>
objectMemory allObjectsDo:
[:obj|
((objectMemory isContextNonImm: obj)
and: [self isMarriedOrWidowedContext: obj]) ifTrue:
[self markContextAsDead: obj]]!
Item was removed:
- ----- Method: StackInterpreter>>booleanCheatV4: (in category 'utilities') -----
- booleanCheatV4: cond
- "cheat the interpreter out of the pleasure of handling the next bytecode IFF it is a jump-on-boolean. Which it is, often enough when the current bytecode is something like bytecodePrimEqual"
- <inline: true>
-
- cond
- ifTrue: [self booleanCheatTrueV4]
- ifFalse: [self booleanCheatFalseV4]!
Item was added:
+ ----- Method: StackInterpreter>>booleanCheatV4: (in category 'utilities') -----
+ booleanCheatV4: cond
+ "cheat the interpreter out of the pleasure of handling the next bytecode IFF it is a jump-on-boolean. Which it is, often enough when the current bytecode is something like bytecodePrimEqual"
+ <inline: true>
+
+ cond
+ ifTrue: [self booleanCheatTrueV4]
+ ifFalse: [self booleanCheatFalseV4]!
Item was changed:
----- Method: StackInterpreter>>bytecodePrimAdd (in category 'common selector sends') -----
bytecodePrimAdd
| rcvr arg result |
rcvr := self internalStackValue: 1.
arg := self internalStackValue: 0.
(self areIntegers: rcvr and: arg)
ifTrue: [result := (objectMemory integerValueOf: rcvr) + (objectMemory integerValueOf: arg).
(objectMemory isIntegerValue: result) ifTrue:
[self internalPop: 2 thenPush: (objectMemory integerObjectOf: result).
^ self fetchNextBytecode "success"]]
ifFalse: [self initPrimCall.
self externalizeIPandSP.
self primitiveFloatAdd: rcvr toArg: arg.
self internalizeIPandSP.
self successful ifTrue: [^ self fetchNextBytecode "success"]].
messageSelector := self specialSelector: 0.
argumentCount := 1.
self normalSend!
Item was changed:
----- Method: StackInterpreter>>bytecodePrimAt (in category 'common selector sends') -----
bytecodePrimAt
"BytecodePrimAt will only succeed if the receiver is in the atCache.
Otherwise it will fail so that the more general primitiveAt will put it in the
cache after validating that message lookup results in a primitive response.
Override to insert in the at: cache here. This is necessary since once there
is a compiled at: primitive method (which doesn't use the at: cache) the only
way something can get installed in the atCache is here."
| index rcvr result atIx |
index := self internalStackTop.
rcvr := self internalStackValue: 1.
((objectMemory isNonImmediate: rcvr)
and: [objectMemory isIntegerObject: index]) ifTrue:
[atIx := rcvr bitAnd: AtCacheMask. "Index into atCache = 4N, for N = 0 ... 7"
(atCache at: atIx+AtCacheOop) ~= rcvr ifTrue:
[lkupClassTag := objectMemory fetchClassTagOfNonImm: rcvr.
messageSelector := self specialSelector: 16.
(self lookupInMethodCacheSel: messageSelector classTag: lkupClassTag) ifFalse:
[argumentCount := 1.
^self commonSend].
primitiveFunctionPointer == #primitiveAt
ifTrue: [self install: rcvr inAtCache: atCache at: atIx string: false]
ifFalse:
[primitiveFunctionPointer == #primitiveStringAt
ifTrue: [self install: rcvr inAtCache: atCache at: atIx string: true]
ifFalse:
[argumentCount := 1.
^self commonSend]]].
self successful ifTrue:
[result := self commonVariable: rcvr at: (objectMemory integerValueOf: index) cacheIndex: atIx].
self successful ifTrue:
[self fetchNextBytecode.
^self internalPop: 2 thenPush: result].
self initPrimCall].
messageSelector := self specialSelector: 16.
argumentCount := 1.
self normalSend!
Item was added:
+ ----- Method: StackInterpreter>>bytecodePrimBitShift (in category 'common selector sends') -----
+ bytecodePrimBitShift
+
+ self initPrimCall.
+ self externalizeIPandSP.
+ self primitiveBitShift.
+ self internalizeIPandSP.
+ self successful ifTrue: [^ self fetchNextBytecode "success"].
+
+ messageSelector := self specialSelector: 12.
+ argumentCount := 1.
+ self normalSend!
Item was removed:
- ----- Method: StackInterpreter>>bytecodePrimBitShift (in category 'common selector sends') -----
- bytecodePrimBitShift
-
- self initPrimCall.
- self externalizeIPandSP.
- self primitiveBitShift.
- self internalizeIPandSP.
- self successful ifTrue: [^ self fetchNextBytecode "success"].
-
- messageSelector := self specialSelector: 12.
- argumentCount := 1.
- self normalSend!
Item was removed:
- ----- Method: StackInterpreter>>bytecodePrimDivide (in category 'common selector sends') -----
- bytecodePrimDivide
- | rcvr arg result |
- rcvr := self internalStackValue: 1.
- arg := self internalStackValue: 0.
- (self areIntegers: rcvr and: arg)
- ifTrue: [rcvr := objectMemory integerValueOf: rcvr.
- arg := objectMemory integerValueOf: arg.
- (arg ~= 0 and: [rcvr \\ arg = 0])
- ifTrue: [result := rcvr // arg.
- "generates C / operation"
- (objectMemory isIntegerValue: result)
- ifTrue: [self internalPop: 2 thenPush: (objectMemory integerObjectOf: result).
- ^ self fetchNextBytecode"success"]]]
- ifFalse: [self initPrimCall.
- self externalizeIPandSP.
- self primitiveFloatDivide: rcvr byArg: arg.
- self internalizeIPandSP.
- self successful ifTrue: [^ self fetchNextBytecode"success"]].
-
- messageSelector := self specialSelector: 9.
- argumentCount := 1.
- self normalSend!
Item was added:
+ ----- Method: StackInterpreter>>bytecodePrimDivide (in category 'common selector sends') -----
+ bytecodePrimDivide
+ | rcvr arg result |
+ rcvr := self internalStackValue: 1.
+ arg := self internalStackValue: 0.
+ (self areIntegers: rcvr and: arg)
+ ifTrue: [rcvr := objectMemory integerValueOf: rcvr.
+ arg := objectMemory integerValueOf: arg.
+ (arg ~= 0 and: [rcvr \\ arg = 0])
+ ifTrue: [result := rcvr // arg.
+ "generates C / operation"
+ (objectMemory isIntegerValue: result)
+ ifTrue: [self internalPop: 2 thenPush: (objectMemory integerObjectOf: result).
+ ^ self fetchNextBytecode"success"]]]
+ ifFalse: [self initPrimCall.
+ self externalizeIPandSP.
+ self primitiveFloatDivide: rcvr byArg: arg.
+ self internalizeIPandSP.
+ self successful ifTrue: [^ self fetchNextBytecode"success"]].
+
+ messageSelector := self specialSelector: 9.
+ argumentCount := 1.
+ self normalSend!
Item was added:
+ ----- Method: StackInterpreter>>bytecodePrimEqual (in category 'common selector sends') -----
+ bytecodePrimEqual
+ | rcvr arg aBool |
+ rcvr := self internalStackValue: 1.
+ arg := self internalStackValue: 0.
+ (self areIntegers: rcvr and: arg) ifTrue: [^self booleanCheat: rcvr = arg].
+
+ self initPrimCall.
+ aBool := self primitiveFloatEqual: rcvr toArg: arg.
+ self successful ifTrue: [^self booleanCheat: aBool].
+
+ messageSelector := self specialSelector: 6.
+ argumentCount := 1.
+ self normalSend!
Item was removed:
- ----- Method: StackInterpreter>>bytecodePrimEqual (in category 'common selector sends') -----
- bytecodePrimEqual
- | rcvr arg aBool |
- rcvr := self internalStackValue: 1.
- arg := self internalStackValue: 0.
- (self areIntegers: rcvr and: arg) ifTrue: [^self booleanCheat: rcvr = arg].
-
- self initPrimCall.
- aBool := self primitiveFloatEqual: rcvr toArg: arg.
- self successful ifTrue: [^self booleanCheat: aBool].
-
- messageSelector := self specialSelector: 6.
- argumentCount := 1.
- self normalSend!
Item was changed:
----- Method: StackInterpreter>>bytecodePrimEqualV4 (in category 'common selector sends') -----
bytecodePrimEqualV4
| rcvr arg aBool |
rcvr := self internalStackValue: 1.
arg := self internalStackValue: 0.
(self areIntegers: rcvr and: arg) ifTrue: [^self booleanCheatV4: rcvr = arg].
self initPrimCall.
aBool := self primitiveFloatEqual: rcvr toArg: arg.
self successful ifTrue: [^self booleanCheatV4: aBool].
messageSelector := self specialSelector: 6.
argumentCount := 1.
self normalSend!
Item was changed:
----- Method: StackInterpreter>>bytecodePrimGreaterThan (in category 'common selector sends') -----
bytecodePrimGreaterThan
| rcvr arg aBool |
rcvr := self internalStackValue: 1.
arg := self internalStackValue: 0.
(self areIntegers: rcvr and: arg) ifTrue:
["The C code can avoid detagging since tagged integers are still signed.
But this means the simulator must override to do detagging."
^self cCode: [self booleanCheat: rcvr > arg]
inSmalltalk: [self booleanCheat: (objectMemory integerValueOf: rcvr) > (objectMemory integerValueOf: arg)]].
self initPrimCall.
aBool := self primitiveFloatGreater: rcvr thanArg: arg.
self successful ifTrue: [^self booleanCheat: aBool].
messageSelector := self specialSelector: 3.
argumentCount := 1.
self normalSend!
Item was changed:
----- Method: StackInterpreter>>bytecodePrimIdentical (in category 'common selector sends') -----
bytecodePrimIdentical
| rcvr arg |
rcvr := self internalStackValue: 1.
(objectMemory isOopForwarded: rcvr) ifTrue:
[rcvr := self handleSpecialSelectorSendFaultFor: rcvr].
arg := self internalStackValue: 0.
(objectMemory isOopForwarded: arg) ifTrue:
[arg := self handleSpecialSelectorSendFaultFor: arg].
self booleanCheat: rcvr = arg!
Item was changed:
----- Method: StackInterpreter>>bytecodePrimLessThan (in category 'common selector sends') -----
bytecodePrimLessThan
| rcvr arg aBool |
rcvr := self internalStackValue: 1.
arg := self internalStackValue: 0.
(self areIntegers: rcvr and: arg) ifTrue:
["The C code can avoid detagging since tagged integers are still signed.
But this means the simulator must override to do detagging."
^self cCode: [self booleanCheat: rcvr < arg]
inSmalltalk: [self booleanCheat: (objectMemory integerValueOf: rcvr) < (objectMemory integerValueOf: arg)]].
self initPrimCall.
aBool := self primitiveFloatLess: rcvr thanArg: arg.
self successful ifTrue: [^ self booleanCheat: aBool].
messageSelector := self specialSelector: 2.
argumentCount := 1.
self normalSend!
Item was changed:
----- Method: StackInterpreter>>bytecodePrimMakePoint (in category 'common selector sends') -----
bytecodePrimMakePoint
self initPrimCall.
self externalizeIPandSP.
self primitiveMakePoint.
self internalizeIPandSP.
self successful ifTrue: [^ self fetchNextBytecode "success"].
messageSelector := self specialSelector: 11.
argumentCount := 1.
self normalSend!
Item was removed:
- ----- Method: StackInterpreter>>bytecodePrimNew (in category 'common selector sends') -----
- bytecodePrimNew
-
- messageSelector := self specialSelector: 28.
- argumentCount := 0.
- self normalSend.
- !
Item was added:
+ ----- Method: StackInterpreter>>bytecodePrimNew (in category 'common selector sends') -----
+ bytecodePrimNew
+
+ messageSelector := self specialSelector: 28.
+ argumentCount := 0.
+ self normalSend.
+ !
Item was changed:
----- Method: StackInterpreter>>bytecodePrimNext (in category 'common selector sends') -----
bytecodePrimNext
messageSelector := self specialSelector: 19.
argumentCount := self specialSelectorNumArgs: 19.
self normalSend.!
Item was changed:
----- Method: StackInterpreter>>bytecodePrimPointX (in category 'common selector sends') -----
bytecodePrimPointX
| rcvr |
self initPrimCall.
rcvr := self internalStackTop.
self assertClassOf: rcvr is: (objectMemory splObj: ClassPoint).
self successful ifTrue:
[self internalStackTopPut: (objectMemory fetchPointer: XIndex ofObject: rcvr).
^self fetchNextBytecode "success"].
primFailCode := 0.
messageSelector := self specialSelector: 30.
argumentCount := 0.
self normalSend!
Item was changed:
----- Method: StackInterpreter>>bytecodePrimPointY (in category 'common selector sends') -----
bytecodePrimPointY
| rcvr |
self initPrimCall.
rcvr := self internalStackTop.
self assertClassOf: rcvr is: (objectMemory splObj: ClassPoint).
self successful ifTrue:
[self internalStackTopPut: (objectMemory fetchPointer: YIndex ofObject: rcvr).
^self fetchNextBytecode "success"].
primFailCode := 0.
messageSelector := self specialSelector: 31.
argumentCount := 0.
self normalSend!
Item was changed:
----- Method: StackInterpreter>>bytecodePrimSize (in category 'common selector sends') -----
bytecodePrimSize
| rcvr sz isString isArray |
self initPrimCall.
rcvr := self internalStackTop.
"Shortcut the mega-lookup for ByteString and Array, the two big consumers of cycles
here. Both of these have compact class indices and neither has any added fields."
isString := self isInstanceOfClassByteString: rcvr.
isString ifTrue:
[sz := objectMemory lengthOf: rcvr.
self internalStackTopPut: (objectMemory integerObjectOf: sz).
^self fetchNextBytecode].
isArray := self isInstanceOfClassArray: rcvr.
isArray ifTrue:
[sz := objectMemory lengthOf: rcvr.
self internalStackTopPut: (objectMemory integerObjectOf: sz).
^self fetchNextBytecode].
messageSelector := self specialSelector: 18.
argumentCount := 0.
self normalSend!
Item was changed:
----- Method: StackInterpreter>>bytecodePrimSpecialSelector24 (in category 'common selector sends') -----
bytecodePrimSpecialSelector24
messageSelector := self specialSelector: 24.
argumentCount := self specialSelectorNumArgs: 24.
self normalSend!
Item was changed:
----- Method: StackInterpreter>>bytecodePrimValue (in category 'common selector sends') -----
bytecodePrimValue
| rcvr isBlock |
rcvr := self internalStackTop.
argumentCount := 0.
isBlock := self isInstanceOfClassBlockClosure: rcvr.
isBlock ifTrue:
[self externalizeIPandSP.
self initPrimCall.
self primitiveClosureValue.
self internalizeIPandSP.
self successful ifTrue:
[^self fetchNextBytecode].
primFailCode := 0].
messageSelector := self specialSelector: 25.
self normalSend!
Item was added:
+ ----- Method: StackInterpreter>>callExternalPrimitive: (in category 'plugin primitive support') -----
+ callExternalPrimitive: functionID
+ "Call the external plugin function identified. In the VM this is an address;
+ see StackInterpreterSimulator for its version."
+
+ <var: #functionID declareC: 'void (*functionID)()'>
+ self dispatchFunctionPointer: functionID!
Item was removed:
- ----- Method: StackInterpreter>>callExternalPrimitive: (in category 'plugin primitive support') -----
- callExternalPrimitive: functionID
- "Call the external plugin function identified. In the VM this is an address;
- see StackInterpreterSimulator for its version."
-
- <var: #functionID declareC: 'void (*functionID)()'>
- self dispatchFunctionPointer: functionID!
Item was changed:
----- Method: StackInterpreter>>canContextSwitchIfActivating:header: (in category 'message sending') -----
canContextSwitchIfActivating: theMethod header: methodHeader
"Context switch should not be allowed on every method activation. In particular
the implementation of ensure: and ifCurtailed: depends on there being no
suspension point on failing primitive 198 (primitiveMarkUnwindMethod).
slowPrimitiveResponse states
``N.B. This means there is no suspension point on primitive failure
which methods such as ensure: and ifCurtailed: rely on.''
Rather than prevent context switch on all primitives but the ones we really need
to be suspension points (primitiveSignal et al) we choose to allow context switch
for all but primitiveMarkUnwindMethod."
| primitiveIndex |
<api>
<inline: true>
primitiveIndex := self primitiveIndexOfMethod: theMethod header: methodHeader.
^self cppIf: true
ifTrue:
[primitiveIndex ~= 198] "primitiveMarkUnwindMethod"
ifFalse:
[primitiveIndex = 0
or: [(primitiveIndex between: 85 and: 88) "primitiveSignal primitiveWait primitiveResume primitiveSuspend"
or: [primitiveIndex = 167]]] "primitiveYield"!
Item was changed:
----- Method: StackInterpreter>>capturePendingFinalizationSignals (in category 'debug support') -----
capturePendingFinalizationSignals
statPendingFinalizationSignals := pendingFinalizationSignals.
!
Item was removed:
- ----- Method: StackInterpreter>>checkCodeIntegrity: (in category 'object memory support') -----
- checkCodeIntegrity: fullGCFlag
- "This is a no-op in the StackVM"
- ^true!
Item was added:
+ ----- Method: StackInterpreter>>checkCodeIntegrity: (in category 'object memory support') -----
+ checkCodeIntegrity: fullGCFlag
+ "This is a no-op in the StackVM"
+ ^true!
Item was changed:
----- Method: StackInterpreter>>checkInterpreterIntegrity (in category 'object memory support') -----
checkInterpreterIntegrity
"Perform an integrity/leak check using the heapMap. Assume
clearLeakMapAndMapAccessibleObjects has set a bit at each
object's header. Check that all oops in the interpreter's state
points to a header. Answer if all checks pass."
| ok |
ok := true.
(objectMemory checkOopIntegrity: objectMemory specialObjectsOop named: 'specialObjectsOop')ifFalse:
[ok := false].
"No longer check messageSelector; it is ephemeral, not living beyond message lookup.
(objectMemory isNonImmediate: messageSelector) ifTrue:
[(objectMemory checkOopIntegrity: messageSelector named: 'messageSelector')ifFalse:
[ok := false]]."
(objectMemory checkOopIntegrity: newMethod named: 'newMethod')ifFalse:
[ok := false].
"No longer check lkupClass; it is ephemeral, not living beyond message lookup.
(objectMemory checkOopIntegrity: lkupClass named: 'lkupClass')ifFalse:
[ok := false]."
(objectMemory checkOopIntegrity: profileProcess named: 'profileProcess')ifFalse:
[ok := false].
(objectMemory checkOopIntegrity: profileMethod named: 'profileMethod')ifFalse:
[ok := false].
(objectMemory checkOopIntegrity: profileSemaphore named: 'profileSemaphore')ifFalse:
[ok := false].
tempOop = 0 ifFalse:
[(objectMemory checkOopIntegrity: tempOop named: 'tempOop')ifFalse:
[ok := false]].
"Callback support - check suspended callback list"
1 to: jmpDepth do:
[:i|
(objectMemory checkOopIntegrity: (suspendedCallbacks at: i) named: 'suspendedCallbacks' index: i) ifFalse:
[ok := false].
(objectMemory checkOopIntegrity: (suspendedMethods at: i) named: 'suspendedMethods' index: i) ifFalse:
[ok := false]].
self checkLogIntegrity ifFalse:
[ok := false].
^ok!
Item was changed:
----- Method: StackInterpreter>>checkIsStillMarriedContext:currentFP: (in category 'frame access') -----
checkIsStillMarriedContext: aContext currentFP: currentFP
"Another version of isWidowedContext:currentFP: for debugging.
This will not bereave a widowed context."
| thePage theFP limitFP |
<inline: false>
<var: #currentFP type: #'char *'>
<var: #thePage type: #'StackPage *'>
<var: #theFP type: #'char *'>
<var: #limitFP type: #'char *'>
(objectMemory isIntegerObject: (objectMemory fetchPointer: SenderIndex ofObject: aContext)) ifFalse:
[^false].
theFP := self frameOfMarriedContext: aContext.
thePage := stackPages stackPageFor: theFP.
limitFP := (thePage = stackPage and: [currentFP notNil])
ifTrue: [currentFP]
ifFalse: [thePage headFP].
^theFP >= limitFP
and: [(objectMemory isNonImmediate: (self frameCallerFP: theFP) asInteger)
and: [(self withSmallIntegerTags: (self frameCallerFP: theFP))
= (objectMemory fetchPointer: InstructionPointerIndex ofObject: aContext)
and: [(self frameMethodObject: theFP)
= (objectMemory fetchPointer: MethodIndex ofObject: aContext)
and: [(self frameHasContext: theFP)
and: [(self frameContext: theFP) = aContext
and: [objectMemory isContext: aContext]]]]]]!
Item was changed:
----- Method: StackInterpreter>>checkOkayFields: (in category 'debug support') -----
checkOkayFields: oop
"Check if the argument is an ok object.
If this is a pointers object, check that its fields are all okay oops."
| hasYoung i fieldOop |
(oop = nil or: [oop = 0]) ifTrue: [ ^true ]. "?? eem 1/16/2013"
(objectMemory isIntegerObject: oop) ifTrue: [ ^true ].
(objectMemory checkOkayOop: oop) ifFalse: [ ^false ].
(objectMemory checkOopHasOkayClass: oop) ifFalse: [ ^false ].
((objectMemory isPointersNonInt: oop) or: [objectMemory isCompiledMethod: oop]) ifFalse: [ ^true ].
hasYoung := objectMemory isYoung: (objectMemory fetchClassOfNonImm: oop).
(objectMemory isCompiledMethod: oop)
ifTrue:
[i := (self literalCountOf: oop) + LiteralStart - 1]
ifFalse:
[(objectMemory isContext: oop)
ifTrue: [i := CtxtTempFrameStart + (self fetchStackPointerOf: oop) - 1]
ifFalse: [i := (objectMemory lengthOf: oop) - 1]].
[i >= 0] whileTrue:
[fieldOop := objectMemory fetchPointer: i ofObject: oop.
(objectMemory isIntegerObject: fieldOop) ifFalse:
[hasYoung := hasYoung or: [objectMemory isYoung: fieldOop].
(objectMemory checkOkayOop: fieldOop) ifFalse: [ ^false ].
(self checkOopHasOkayClass: fieldOop) ifFalse: [ ^false ]].
i := i - 1].
hasYoung ifTrue:
[^objectMemory checkOkayYoungReferrer: oop].
^true!
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 + BytesPerWord].
[frameRcvrOffset := self frameReceiverOffset: theFP.
[theSP <= frameRcvrOffset] whileTrue:
[oop := stackPages longAt: theSP.
(objectMemory isIntegerObject: oop) ifFalse:
[ok := ok & (self checkOkayFields: oop)].
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 + BytesPerWord.
theFP := callerFP].
theSP := self isCog
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 + BytesPerWord].
^ok!
Item was removed:
- ----- Method: StackInterpreter>>checkProfileTick: (in category 'process primitive support') -----
- checkProfileTick: aPrimitiveMethod
- "Check if the profile timer has expired and if so take a sample.
- If the primitive has failed sample the profileMethod as nil."
- <inline: false>
- self assert: nextProfileTick ~= 0.
- self ioHighResClock >= nextProfileTick ifTrue:
- [profileProcess := self activeProcess.
- profileMethod := self successful ifTrue: [aPrimitiveMethod] ifFalse: [objectMemory nilObject].
- self forceInterruptCheck.
- nextProfileTick := 0]!
Item was added:
+ ----- Method: StackInterpreter>>checkProfileTick: (in category 'process primitive support') -----
+ checkProfileTick: aPrimitiveMethod
+ "Check if the profile timer has expired and if so take a sample.
+ If the primitive has failed sample the profileMethod as nil."
+ <inline: false>
+ self assert: nextProfileTick ~= 0.
+ self ioHighResClock >= nextProfileTick ifTrue:
+ [profileProcess := self activeProcess.
+ profileMethod := self successful ifTrue: [aPrimitiveMethod] ifFalse: [objectMemory nilObject].
+ self forceInterruptCheck.
+ nextProfileTick := 0]!
Item was added:
+ ----- Method: StackInterpreter>>closureIn:numArgs:instructionPointer:numCopiedValues: (in category 'control primitives') -----
+ closureIn: context numArgs: numArgs instructionPointer: initialIP numCopiedValues: numCopied
+ | newClosure |
+ <inline: true>
+ ClassBlockClosureCompactIndex ~= 0
+ ifTrue:
+ [newClosure := objectMemory
+ eeInstantiateClassIndex: ClassBlockClosureCompactIndex
+ format: objectMemory indexablePointersFormat
+ numSlots: ClosureFirstCopiedValueIndex + numCopied]
+ ifFalse:
+ [newClosure := objectMemory
+ eeInstantiateSmallClass: (objectMemory splObj: ClassBlockClosure)
+ numSlots: ClosureFirstCopiedValueIndex + numCopied].
+ "Assume: have just allocated a new closure; it must be young. Thus, can use unchecked stores."
+ objectMemory storePointerUnchecked: ClosureOuterContextIndex ofObject: newClosure withValue: context.
+ objectMemory storePointerUnchecked: ClosureStartPCIndex ofObject: newClosure withValue: (objectMemory integerObjectOf: initialIP).
+ objectMemory storePointerUnchecked: ClosureNumArgsIndex ofObject: newClosure withValue: (objectMemory integerObjectOf: numArgs).
+ ^newClosure!
Item was removed:
- ----- Method: StackInterpreter>>closureIn:numArgs:instructionPointer:numCopiedValues: (in category 'control primitives') -----
- closureIn: context numArgs: numArgs instructionPointer: initialIP numCopiedValues: numCopied
- | newClosure |
- <inline: true>
- ClassBlockClosureCompactIndex ~= 0
- ifTrue:
- [newClosure := objectMemory
- eeInstantiateClassIndex: ClassBlockClosureCompactIndex
- format: objectMemory indexablePointersFormat
- numSlots: ClosureFirstCopiedValueIndex + numCopied]
- ifFalse:
- [newClosure := objectMemory
- eeInstantiateSmallClass: (objectMemory splObj: ClassBlockClosure)
- numSlots: ClosureFirstCopiedValueIndex + numCopied].
- "Assume: have just allocated a new closure; it must be young. Thus, can use unchecked stores."
- objectMemory storePointerUnchecked: ClosureOuterContextIndex ofObject: newClosure withValue: context.
- objectMemory storePointerUnchecked: ClosureStartPCIndex ofObject: newClosure withValue: (objectMemory integerObjectOf: initialIP).
- objectMemory storePointerUnchecked: ClosureNumArgsIndex ofObject: newClosure withValue: (objectMemory integerObjectOf: numArgs).
- ^newClosure!
Item was added:
+ ----- Method: StackInterpreter>>commonAt: (in category 'indexing primitive support') -----
+ commonAt: stringy
+ "This code is called if the receiver responds primitively to at:.
+ N.B. this does *not* use the at cache, instead inlining stObject:at:.
+ Using the at cache here would require that callers set messageSelector
+ and lkupClass and that is onerous and error-prone, and in any case,
+ inlining produces much better performance than using the at cache here."
+ | index rcvr result |
+ <inline: true> "to get it inlined in primitiveAt and primitiveStringAt"
+ self initPrimCall.
+ rcvr := self stackValue: 1.
+ (objectMemory isImmediate: rcvr) ifTrue:
+ [^self primitiveFailFor: PrimErrInappropriate].
+ index := self stackTop.
+ "No need to test for large positive integers here. No object has 1g elements"
+ (objectMemory isIntegerObject: index) ifFalse:
+ [^self primitiveFailFor: PrimErrBadArgument].
+ index := objectMemory integerValueOf: index.
+ result := self stObject: rcvr at: index.
+ self successful ifTrue:
+ [stringy ifTrue: [result := self characterForAscii: (objectMemory integerValueOf: result)].
+ ^self pop: argumentCount+1 thenPush: result]!
Item was removed:
- ----- Method: StackInterpreter>>commonAt: (in category 'indexing primitive support') -----
- commonAt: stringy
- "This code is called if the receiver responds primitively to at:.
- N.B. this does *not* use the at cache, instead inlining stObject:at:.
- Using the at cache here would require that callers set messageSelector
- and lkupClass and that is onerous and error-prone, and in any case,
- inlining produces much better performance than using the at cache here."
- | index rcvr result |
- <inline: true> "to get it inlined in primitiveAt and primitiveStringAt"
- self initPrimCall.
- rcvr := self stackValue: 1.
- (objectMemory isImmediate: rcvr) ifTrue:
- [^self primitiveFailFor: PrimErrInappropriate].
- index := self stackTop.
- "No need to test for large positive integers here. No object has 1g elements"
- (objectMemory isIntegerObject: index) ifFalse:
- [^self primitiveFailFor: PrimErrBadArgument].
- index := objectMemory integerValueOf: index.
- result := self stObject: rcvr at: index.
- self successful ifTrue:
- [stringy ifTrue: [result := self characterForAscii: (objectMemory integerValueOf: result)].
- ^self pop: argumentCount+1 thenPush: result]!
Item was changed:
----- Method: StackInterpreter>>commonAtPut: (in category 'indexing primitive support') -----
commonAtPut: stringy
"This code is called if the receiver responds primitively to at:Put:.
N.B. this does *not* use the at cache, instead inlining stObject:at:put:.
Using the at cache here would require that callers set messageSelector
and lkupClass and that is onerous and error-prone, and in any case,
inlining produces much better performance than using the at cache here."
| value index rcvr |
<inline: true> "to get it inlined in primitiveAtPut and primitiveStringAtPut"
value := self stackTop.
self initPrimCall.
rcvr := self stackValue: 2.
(objectMemory isNonImmediate: rcvr) ifFalse:
[^self primitiveFailFor: PrimErrInappropriate].
index := self stackValue: 1.
"No need to test for large positive integers here. No object has 1g elements"
(objectMemory isIntegerObject: index) ifFalse:
[^self primitiveFailFor: PrimErrBadArgument].
index := objectMemory integerValueOf: index.
stringy
ifTrue: [self stObject: rcvr at: index put: (self asciiOfCharacter: value)]
ifFalse: [self stObject: rcvr at: index put: value].
self successful ifTrue:
[^self pop: argumentCount+1 thenPush: value]!
Item was changed:
----- Method: StackInterpreter>>commonVariable:at:cacheIndex: (in category 'indexing primitive support') -----
commonVariable: rcvr at: index cacheIndex: atIx
"This code assumes the receiver has been identified at location atIx in the atCache."
| stSize fmt fixedFields result |
<inline: true>
stSize := atCache at: atIx+AtCacheSize.
((self oop: index isGreaterThanOrEqualTo: 1)
and: [self oop: index isLessThanOrEqualTo: stSize]) ifTrue:
[fmt := atCache at: atIx+AtCacheFmt.
fmt <= objectMemory weakArrayFormat ifTrue:
[self assert: (objectMemory isContextNonImm: rcvr) not.
fixedFields := atCache at: atIx+AtCacheFixedFields.
^objectMemory fetchPointer: index + fixedFields - 1 ofObject: rcvr].
fmt < objectMemory firstByteFormat ifTrue: "Bitmap"
[result := objectMemory fetchLong32: index - 1 ofObject: rcvr.
^self positive32BitIntegerFor: result].
fmt >= objectMemory firstStringyFakeFormat "Note fmt >= firstStringyFormat is an artificial flag for strings"
ifTrue: "String"
[^self characterForAscii: (objectMemory fetchByte: index - 1 ofObject: rcvr)]
ifFalse:
[(fmt < objectMemory firstCompiledMethodFormat "ByteArray"
or: [index >= (self firstByteIndexOfMethod: rcvr) "CompiledMethod"]) ifTrue:
[^objectMemory integerObjectOf: (objectMemory fetchByte: index - 1 ofObject: rcvr)]]].
^self primitiveFailFor: ((objectMemory isIndexable: rcvr)
ifFalse: [PrimErrBadReceiver]
ifTrue: [PrimErrBadIndex])!
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 + BaseHeaderSize.
self longAt: obj + BaseHeaderSize put: (self longAt: obj + BaseHeaderSize + 4).
self longAt: obj + BaseHeaderSize + 4 put: temp]]!
Item was changed:
----- Method: StackInterpreter>>copiedValueCountOfClosure: (in category 'internal interpreter access') -----
copiedValueCountOfClosure: closurePointer
<api> "for Cogit"
^(objectMemory fetchWordLengthOf: closurePointer) - ClosureFirstCopiedValueIndex!
Item was changed:
----- Method: StackInterpreter>>copyBitsFrom:to:at: (in category 'bitblt support') -----
copyBitsFrom: x0 to: x1 at: y
"This entry point needs to be implemented for the interpreter proxy.
Since BitBlt is now a plugin we need to look up BitBltPlugin:=copyBitsFrom:to:at:
and call it. This entire mechanism should eventually go away and be
replaced with a dynamic lookup from BitBltPlugin itself but for backward
compatibility this stub is provided"
| fn |
<var: #fn type: 'void *'>
fn := self ioLoadFunction: 'copyBitsFromtoat' From: 'BitBltPlugin'.
fn = 0 ifTrue: [^self primitiveFail].
^self cCode: '((sqInt (*)(sqInt, sqInt, sqInt))fn)(x0, x1, y)'!
Item was changed:
----- Method: StackInterpreter>>cr (in category 'debug printing') -----
cr
"For testing in Smalltalk, this method should be overridden in a subclass."
<inline: true>
self printf: '\n'!
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
eeInstantiateClassIndex: ClassArrayCompactIndex
format: objectMemory arrayFormat
numSlots: argumentCount.
message := objectMemory
eeInstantiateClassIndex: ClassMessageCompactIndex
format: objectMemory nonIndexablePointerFormat
numSlots: MessageLookupClassIndex + 1]
ifFalse:
[argumentArray := objectMemory
eeInstantiateClass: (objectMemory splObj: ClassArray)
indexableSize: argumentCount.
message := objectMemory
eeInstantiateClass: (objectMemory splObj: ClassMessage)
indexableSize: 0].
"Since the array is new can use unchecked stores."
(argumentCount - 1) * 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>>divorceAllFrames (in category 'frame access') -----
divorceAllFrames
| activeContext |
<inline: false>
<var: #aPage type: #'StackPage *'>
stackPage ~= 0 ifTrue:
[self externalWriteBackHeadFramePointers].
activeContext := self ensureFrameIsMarried: framePointer SP: stackPointer.
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 + 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>>dumpImage: (in category 'image save/restore') -----
dumpImage: fileName
"Dump the entire image out to the given file. Intended for debugging only."
| f dataSize result |
<export: true>
<var: #f type: 'sqImageFile'>
f := self cCode: 'sqImageFileOpen(pointerForOop(fileName), "wb")'.
f = nil ifTrue: [^-1].
dataSize := objectMemory endOfMemory - objectMemory startOfMemory.
result := self cCode: 'sqImageFileWrite(pointerForOop(memory), sizeof(unsigned char), dataSize, f)'.
self cCode: 'sqImageFileClose(f)'.
^result
!
Item was changed:
----- Method: StackInterpreter>>dumpPrimTraceLog (in category 'debug support') -----
dumpPrimTraceLog
"Dummy definition to allow the StackInterpreter to link against the Cog run-time."
<api>!
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>>enterSmalltalkExecutiveFromCallback (in category 'callback support') -----
enterSmalltalkExecutiveFromCallback
<inline: true>
self interpret!
Item was changed:
----- Method: StackInterpreter>>establishFrameForContextToReturnTo: (in category 'frame access') -----
establishFrameForContextToReturnTo: contextToReturnTo
| thePage |
<var: #thePage type: #'StackPage *'>
<returnTypeC: 'char *'>
(objectMemory isContext: contextToReturnTo) ifFalse:
[^0].
(self isMarriedOrWidowedContext: contextToReturnTo) ifTrue:
[(self isWidowedContext: contextToReturnTo) ifTrue:
["error: home's sender is dead; cannot return"
^0].
^self frameOfMarriedContext: contextToReturnTo].
(objectMemory isIntegerObject: (objectMemory fetchPointer: InstructionPointerIndex ofObject: contextToReturnTo)) ifFalse:
[^0].
thePage := self makeBaseFrameFor: contextToReturnTo.
stackPages markStackPageMostRecentlyUsed: thePage.
^thePage baseFP!
Item was added:
+ ----- Method: StackInterpreter>>expandCases (in category 'translation support') -----
+ expandCases
+ "For translation only; noop when running in Smalltalk.
+ Must not be inlined otherwise the directive will disappear!!"
+ <inline: false>!
Item was removed:
- ----- Method: StackInterpreter>>expandCases (in category 'translation support') -----
- expandCases
- "For translation only; noop when running in Smalltalk.
- Must not be inlined otherwise the directive will disappear!!"
- <inline: false>!
Item was changed:
----- Method: StackInterpreter>>extJumpIfFalse (in category 'jump bytecodes') -----
extJumpIfFalse
"244 11110100 i i i i i i i i Pop and Jump 0n False i i i i i i i i (+ Extend B * 256, where Extend B >= 0)"
| byte offset |
byte := self fetchByte.
offset := byte + (extB << 8).
extB := 0.
self jumplfFalseBy: offset!
Item was changed:
----- Method: StackInterpreter>>extJumpIfTrue (in category 'jump bytecodes') -----
extJumpIfTrue
"243 11110011 i i i i i i i i Pop and Jump 0n True i i i i i i i i (+ Extend B * 256, where Extend B >= 0)"
| byte offset |
byte := self fetchByte.
offset := byte + (extB << 8).
extB := 0.
self jumplfTrueBy: offset!
Item was changed:
----- Method: StackInterpreter>>extPushClosureBytecode (in category 'stack bytecodes') -----
extPushClosureBytecode
"253 11111101 eei i i kkk jjjjjjjj Push Closure Num Copied iii (+ Ext A // 16 * 8) Num Args kkk (+ Ext A \\ 16 * 8) BlockSize jjjjjjjj (+ Ext B * 256). ee = num extensions.
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."
| byte numArgs numCopied blockSize |
byte := self fetchByte.
numArgs := (byte bitAnd: 7) + (extA \\ 16 * 8).
numCopied := ((byte >> 3) bitAnd: 7) + (extA // 16 * 8).
extA := 0.
blockSize := self fetchByte + (extB << 8).
extB := 0.
self pushClosureNumArgs: numArgs copiedValues: numCopied blockSize: blockSize!
Item was changed:
----- Method: StackInterpreter>>extPushIntegerBytecode (in category 'stack bytecodes') -----
extPushIntegerBytecode
"229 11100101 i i i i i i i i Push Integer #iiiiiiii (+ Extend B * 256, where bbbbbbbb = sddddddd, e.g. -32768 = i=0, a=0, s=1)"
| value |
value := self fetchByte + (extB << 8).
self fetchNextBytecode.
extB := 0.
self internalPush: (objectMemory integerObjectOf: value)!
Item was changed:
----- Method: StackInterpreter>>extPushLiteralVariableBytecode (in category 'stack bytecodes') -----
extPushLiteralVariableBytecode
"227 11100011 i i i i i i i i Push Literal Variable #iiiiiiii (+ Extend A * 256)"
| index |
index := self fetchByte + (extA << 8).
self fetchNextBytecode.
extA := 0.
self pushLiteralVariable: index!
Item was changed:
----- Method: StackInterpreter>>extPushPseudoVariableOrOuterBytecode (in category 'stack bytecodes') -----
extPushPseudoVariableOrOuterBytecode
"77 01001101 Push false [* 1:true, 2:nil, 3:thisContext, ..., -N: pushExplicitOuter: N, N = Extend B]"
| thing |
self fetchNextBytecode.
thing := extB
caseOf: {
[0] -> [^self internalPush: objectMemory falseObject].
[1] -> [objectMemory trueObject].
[2] -> [objectMemory nilObject].
[3] -> [| context |
context := self ensureFrameIsMarried: localFP SP: localSP.
context]
}
otherwise:
[extB < 0
ifTrue:
[self
explicitOuterReceiver: 0 - extB
withObject: self receiver
withMixin: (self methodClassOf: method)]
ifFalse:
[self error: 'undefined extension for extPushPseudoVariableOrOuter'.
objectMemory nilObject]].
extB := 0.
self internalPush: thing!
Item was changed:
----- Method: StackInterpreter>>extPushReceiverVariableBytecode (in category 'stack bytecodes') -----
extPushReceiverVariableBytecode
"226 11100010 i i i i i i i i Push Receiver Variable #iiiiiiii (+ Extend A * 256)"
| index |
index := self fetchByte + (extA << 8).
self fetchNextBytecode.
extA := 0.
self pushMaybeContextReceiverVariable: index!
Item was added:
+ ----- Method: StackInterpreter>>extSendAbsentImplicitBytecode (in category 'send bytecodes') -----
+ extSendAbsentImplicitBytecode
+ "240 11110000 i i i i i j j j Send To Absent Implicit Receiver Literal Selector #iiiii (+ Extend A * 32) with jjj (+ Extend B * 8) Arguments"
+ | byte |
+ byte := self fetchByte.
+ messageSelector := self literal: (byte >> 3) + (extA << 5).
+ extA := 0.
+ argumentCount := (byte bitAnd: 7) + (extB << 3).
+ extB := 0.
+ self commonSendAbsentImplicit!
Item was removed:
- ----- Method: StackInterpreter>>extSendAbsentImplicitBytecode (in category 'send bytecodes') -----
- extSendAbsentImplicitBytecode
- "240 11110000 i i i i i j j j Send To Absent Implicit Receiver Literal Selector #iiiii (+ Extend A * 32) with jjj (+ Extend B * 8) Arguments"
- | byte |
- byte := self fetchByte.
- messageSelector := self literal: (byte >> 3) + (extA << 5).
- extA := 0.
- argumentCount := (byte bitAnd: 7) + (extB << 3).
- extB := 0.
- self commonSendAbsentImplicit!
Item was changed:
----- Method: StackInterpreter>>extStoreLiteralVariableBytecode (in category 'stack bytecodes') -----
extStoreLiteralVariableBytecode
"233 11101001 i i i i i i i i Store Literal Variable #iiiiiiii (+ Extend A * 256)"
| association variableIndex |
variableIndex := self fetchByte + (extA << 8).
self fetchNextBytecode.
extA := 0.
association := self literal: variableIndex.
objectMemory storePointer: ValueIndex ofObject: association withValue: self internalStackTop!
Item was changed:
----- Method: StackInterpreter>>extStoreReceiverVariableBytecode (in category 'stack bytecodes') -----
extStoreReceiverVariableBytecode
"232 11101000 i i i i i i i i Store Receiver Variable #iiiiiii (+ Extend A * 256)"
| variableIndex |
variableIndex := self fetchByte + (extA << 8).
self fetchNextBytecode.
extA := 0.
self storeMaybeContextReceiverVariable: variableIndex withValue: self internalStackTop!
Item was changed:
----- Method: StackInterpreter>>extUnconditionalJump (in category 'jump bytecodes') -----
extUnconditionalJump
"242 11110010 i i i i i i i i Jump i i i i i i i i (+ Extend B * 256, where bbbbbbbb = sddddddd, e.g. -32768 = i=0, a=0, s=1)"
| byte offset |
byte := self fetchByte.
offset := byte + (extB << 8).
extB := 0.
localIP := localIP + offset.
self ifBackwardsCheckForEvents: offset.
self fetchNextBytecode!
Item was changed:
----- Method: StackInterpreter>>extendedStoreAndPopBytecode (in category 'stack bytecodes') -----
extendedStoreAndPopBytecode
self extendedStoreBytecode.
self internalPop: 1.
!
Item was changed:
----- Method: StackInterpreter>>extendedStoreBytecode (in category 'stack bytecodes') -----
extendedStoreBytecode
| descriptor variableType variableIndex association |
<inline: true>
descriptor := self fetchByte.
self fetchNextBytecode.
variableType := descriptor >> 6 bitAnd: 3.
variableIndex := descriptor bitAnd: 63.
variableType = 0 ifTrue:
[^objectMemory storePointer: variableIndex ofObject: self receiver withValue: self internalStackTop].
variableType = 1 ifTrue:
[^self temporary: variableIndex in: localFP put: self internalStackTop].
variableType = 3 ifTrue:
[association := self literal: variableIndex.
^objectMemory storePointer: ValueIndex ofObject: association withValue: self internalStackTop].
self error: 'illegal store'.
^nil!
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) - BytesPerWord.
stackPages longAt: callerSP put: callerIP.
self setHeadFP: callerFP andSP: callerSP inPage: thePage]
!
Item was changed:
----- Method: StackInterpreter>>externalEnsureIsBaseFrame: (in category 'frame access') -----
externalEnsureIsBaseFrame: aFramePtr
"Ensure aFramePtr is a base frame. Then we can assign its sender.
Answer the possibly moved location of the frame."
| theFP thePage onCurrent |
<var: #aFramePtr type: #'char *'>
<var: #theFP type: #'char *'>
<var: #thePage type: #'StackPage *'>
<returnTypeC: 'char *'>
(self isBaseFrame: aFramePtr) ifTrue:
[^aFramePtr].
theFP := aFramePtr.
thePage := stackPages stackPageFor: theFP.
onCurrent := thePage = stackPage.
"Storing the frame's sender with its caller's context
has the side effect of making theFP a base frame."
theFP := self
storeSenderOfFrame: theFP
withValue: (self ensureCallerContext: theFP).
onCurrent
ifTrue:
[self assert: stackPage ~~ thePage. "stackPage has moved to a new page"
framePointer := stackPage headFP.
stackPointer := stackPage headSP]
ifFalse:
[stackPages markStackPageMostRecentlyUsed: stackPage].
self assert: stackPages pageListIsWellFormed.
self assert: stackPage = stackPages mostRecentlyUsedPage.
^theFP!
Item was changed:
----- Method: StackInterpreter>>externalInstVar:ofContext: (in category 'frame access') -----
externalInstVar: offset ofContext: aContext
"Fetch an instance variable from a maybe married context.
If the context is still married compute the value of the
relevant inst var from the spouse frame's state."
| spouseFP |
<var: #spouseFP type: #'char *'>
<var: #thePage type: #'StackPage *'>
<var: #theFPAbove type: #'char *'>
self assert: (objectMemory isContext: aContext).
"method, closureOrNil & receiver need no special handling; only
sender, pc & stackp have to be computed for married contexts."
(offset < MethodIndex
and: [self isMarriedOrWidowedContext: aContext]) ifFalse:
[^objectMemory fetchPointer: offset ofObject: aContext].
self externalWriteBackHeadFramePointers.
(self isWidowedContext: aContext) ifTrue:
[^objectMemory fetchPointer: offset ofObject: aContext].
spouseFP := self frameOfMarriedContext: aContext.
offset = SenderIndex ifTrue:
[^self ensureCallerContext: spouseFP].
offset = StackPointerIndex ifTrue:
[self assert: ReceiverIndex + (self stackPointerIndexForFrame: spouseFP) < (objectMemory lengthOf: aContext).
^objectMemory integerObjectOf: (self stackPointerIndexForFrame: spouseFP)].
offset = InstructionPointerIndex ifTrue:
[| theIP thePage theFPAbove |
spouseFP = framePointer
ifTrue: [theIP := self oopForPointer: instructionPointer]
ifFalse:
[thePage := stackPages stackPageFor: spouseFP.
theFPAbove := self findFrameAbove: spouseFP inPage: thePage.
theIP := theFPAbove == 0
ifTrue: [stackPages longAt: thePage headSP]
ifFalse:[self oopForPointer: (self frameCallerSavedIP: theFPAbove)]].
^self contextInstructionPointer: theIP frame: spouseFP].
self error: 'bad index'.
^0!
Item was changed:
----- Method: StackInterpreter>>externalInstVar:ofContext:put: (in category 'frame access') -----
externalInstVar: index ofContext: maybeMarriedContext put: anOop
| theFP thePage onCurrentPage |
<var: #theFP type: #'char *'>
<var: #thePage type: #'StackPage *'>
self assert: (objectMemory isContext: maybeMarriedContext).
self externalWriteBackHeadFramePointers.
"Assign the field of a married context."
(self isStillMarriedContext: maybeMarriedContext) ifFalse:
[objectMemory storePointer: index ofObject: maybeMarriedContext withValue: anOop.
index = StackPointerIndex ifTrue:
[self ensureContextIsExecutionSafeAfterAssignToStackPointer: maybeMarriedContext].
^nil].
theFP := self frameOfMarriedContext: maybeMarriedContext.
thePage := stackPages stackPageFor: theFP.
self assert: stackPage = stackPages mostRecentlyUsedPage.
onCurrentPage := thePage = stackPage.
index == SenderIndex
ifTrue:
[self storeSenderOfFrame: theFP withValue: anOop]
ifFalse:
[self externalDivorceFrame: theFP andContext: maybeMarriedContext.
objectMemory storePointer: index ofObject: maybeMarriedContext withValue: anOop.
index = StackPointerIndex ifTrue:
[self ensureContextIsExecutionSafeAfterAssignToStackPointer: maybeMarriedContext]].
onCurrentPage
ifTrue:
[framePointer := stackPage headFP.
stackPointer := stackPage headSP]
ifFalse:
[stackPages markStackPageMostRecentlyUsed: stackPage].
stackPages assert: stackPage = stackPages mostRecentlyUsedPage.
stackPages assert: stackPages pageListIsWellFormed.
stackPages assert: self validStackPageBaseFrames!
Item was changed:
----- Method: StackInterpreter>>fetchStackPointerOf: (in category 'internal interpreter access') -----
fetchStackPointerOf: aContext
"Return the stackPointer of a Context or BlockContext.
Does not deal with married contexts. Use only for debug
printing or object tracing functions. To obtain an accurate
stack pointer use stackPointerForMaybeMarriedContext:"
| sp |
<inline: true>
sp := objectMemory fetchPointer: StackPointerIndex ofObject: aContext.
(objectMemory isIntegerObject: sp) ifFalse: [^0].
self assert: ReceiverIndex + (objectMemory integerValueOf: sp) < (objectMemory lengthOf: aContext).
^objectMemory integerValueOf: sp!
Item was changed:
----- Method: StackInterpreter>>findClassOfMethod:forReceiver: (in category 'debug support') -----
findClassOfMethod: meth forReceiver: rcvr
| rclass |
((objectMemory addressCouldBeOop: rcvr)
and: [(objectMemory isOopForwarded: rcvr) not]) ifTrue:
[rclass := objectMemory fetchClassOf: rcvr.
(self addressCouldBeClassObj: rclass) ifTrue:
[rclass := self findClassContainingMethod: meth startingAt: rclass.
rclass ~= objectMemory nilObject ifTrue:
[^rclass]]].
((objectMemory addressCouldBeObj: meth)
and: [objectMemory isCompiledMethod: meth]) ifFalse:
[^objectMemory nilObject].
^self findClassContainingMethod: meth startingAt: (self methodClassOf: meth)!
Item was changed:
----- Method: StackInterpreter>>findFrameAbove:inPage: (in category 'frame access') -----
findFrameAbove: theFP inPage: thePage
"Answer the frame above theFP (adjacent frame nearest head end).
If theFP is the head frame answer 0."
<var: #theFP type: #'char *'>
<var: #thePage type: #'StackPage *'>
| fp callerFP |
<var: #fp type: #'char *'>
<var: #callerFP type: #'char *'>
<returnTypeC: #'char *'>
fp := thePage headFP.
fp = theFP ifTrue:
[^0].
[(callerFP := self frameCallerFP: fp) ~= 0] whileTrue:
[callerFP = theFP ifTrue:
[^fp].
fp := callerFP].
self error: 'did not find theFP in stack page'.
^0!
Item was changed:
----- Method: StackInterpreter>>findHomeForContext: (in category 'debug printing') -----
findHomeForContext: aContext
| closureOrNil |
<inline: false>
(objectMemory isContext: aContext) ifFalse:
[^nil].
closureOrNil := objectMemory fetchPointer: ClosureIndex ofObject: aContext.
closureOrNil = objectMemory nilObject ifTrue:
[^aContext].
(objectMemory fetchClassOf: closureOrNil) ~= (objectMemory splObj: ClassBlockClosure) ifTrue:
[^nil].
^self findHomeForContext: (objectMemory fetchPointer: ClosureOuterContextIndex ofObject: closureOrNil)!
Item was removed:
- ----- Method: StackInterpreter>>findNewMethodInClassTag: (in category 'message sending') -----
- findNewMethodInClassTag: classTagArg
- "Find the compiled method to be run when the current
- messageSelector is sent to the given class, setting the values
- of 'newMethod' and 'primitiveIndex'."
- | ok class classTag |
- <inline: false>
- ok := self lookupInMethodCacheSel: messageSelector classTag: classTagArg.
- ok ifFalse: "entry was not found in the cache; look it up the hard way "
- [classTag := classTagArg.
- ((objectMemory isOopForwarded: messageSelector)
- or: [objectMemory isForwardedClassTag: classTag]) ifTrue:
- [(objectMemory isOopForwarded: messageSelector) ifTrue:
- [messageSelector := self handleForwardedSelectorFaultFor: messageSelector].
- (objectMemory isForwardedClassTag: classTag) ifTrue:
- [classTag := self handleForwardedSendFaultFor: classTag].
- ok := self lookupInMethodCacheSel: messageSelector classTag: classTag.
- ok ifTrue:
- [^nil]].
- class := objectMemory classForClassTag: classTag.
- self lookupMethodInClass: class.
- self addNewMethodToCache: class]!
Item was added:
+ ----- Method: StackInterpreter>>findNewMethodInClassTag: (in category 'message sending') -----
+ findNewMethodInClassTag: classTagArg
+ "Find the compiled method to be run when the current
+ messageSelector is sent to the given class, setting the values
+ of 'newMethod' and 'primitiveIndex'."
+ | ok class classTag |
+ <inline: false>
+ ok := self lookupInMethodCacheSel: messageSelector classTag: classTagArg.
+ ok ifFalse: "entry was not found in the cache; look it up the hard way "
+ [classTag := classTagArg.
+ ((objectMemory isOopForwarded: messageSelector)
+ or: [objectMemory isForwardedClassTag: classTag]) ifTrue:
+ [(objectMemory isOopForwarded: messageSelector) ifTrue:
+ [messageSelector := self handleForwardedSelectorFaultFor: messageSelector].
+ (objectMemory isForwardedClassTag: classTag) ifTrue:
+ [classTag := self handleForwardedSendFaultFor: classTag].
+ ok := self lookupInMethodCacheSel: messageSelector classTag: classTag.
+ ok ifTrue:
+ [^nil]].
+ class := objectMemory classForClassTag: classTag.
+ self lookupMethodInClass: class.
+ self addNewMethodToCache: class]!
Item was changed:
----- Method: StackInterpreter>>findSPOf:on: (in category 'frame access') -----
findSPOf: theFP on: thePage
"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 *'>
<returnTypeC: #'char *'>
| theSP |
<inline: false>
<var: #theSP type: #'char *'>
theSP := self findSPOrNilOf: theFP on: thePage startingFrom: thePage headFP.
theSP notNil ifTrue:
[^theSP].
self error: 'did not find theFP in stack page'.
^0!
Item was added:
+ ----- Method: StackInterpreter>>findSelectorAndClassForMethod:lookupClass:do: (in category 'debug support') -----
+ findSelectorAndClassForMethod: meth lookupClass: startClass do: binaryBlock
+ "Search startClass' class hierarchy searching for method and if found, evaluate aBinaryBlock
+ with the selector and class where the method is found. Otherwise evaluate aBinaryBlock
+ with doesNotUnderstand: and nil."
+ | currClass classDict classDictSize methodArray i |
+ currClass := startClass.
+ [classDict := objectMemory fetchPointer: MethodDictionaryIndex ofObject: currClass.
+ classDictSize := objectMemory fetchWordLengthOf: classDict.
+ methodArray := objectMemory fetchPointer: MethodArrayIndex ofObject: classDict.
+ i := 0.
+ [i <= (classDictSize - SelectorStart)] whileTrue:
+ [meth = (objectMemory fetchPointer: i ofObject: methodArray) ifTrue:
+ [^binaryBlock
+ value: (objectMemory fetchPointer: i + SelectorStart ofObject: classDict)
+ value: currClass].
+ i := i + 1].
+ currClass := self superclassOf: currClass.
+ currClass = objectMemory nilObject] whileFalse.
+ ^binaryBlock "method not found in superclass chain"
+ value: (objectMemory splObj: SelectorDoesNotUnderstand)
+ value: nil!
Item was removed:
- ----- Method: StackInterpreter>>findSelectorAndClassForMethod:lookupClass:do: (in category 'debug support') -----
- findSelectorAndClassForMethod: meth lookupClass: startClass do: binaryBlock
- "Search startClass' class hierarchy searching for method and if found, evaluate aBinaryBlock
- with the selector and class where the method is found. Otherwise evaluate aBinaryBlock
- with doesNotUnderstand: and nil."
- | currClass classDict classDictSize methodArray i |
- currClass := startClass.
- [classDict := objectMemory fetchPointer: MethodDictionaryIndex ofObject: currClass.
- classDictSize := objectMemory fetchWordLengthOf: classDict.
- methodArray := objectMemory fetchPointer: MethodArrayIndex ofObject: classDict.
- i := 0.
- [i <= (classDictSize - SelectorStart)] whileTrue:
- [meth = (objectMemory fetchPointer: i ofObject: methodArray) ifTrue:
- [^binaryBlock
- value: (objectMemory fetchPointer: i + SelectorStart ofObject: classDict)
- value: currClass].
- i := i + 1].
- currClass := self superclassOf: currClass.
- currClass = objectMemory nilObject] whileFalse.
- ^binaryBlock "method not found in superclass chain"
- value: (objectMemory splObj: SelectorDoesNotUnderstand)
- value: nil!
Item was changed:
----- Method: StackInterpreter>>findSelectorOfMethod: (in category 'debug support') -----
findSelectorOfMethod: methArg
| meth classObj classDict classDictSize methodArray i |
(objectMemory addressCouldBeObj: methArg) ifFalse:
[^objectMemory nilObject].
meth := (objectMemory isForwarded: methArg)
ifTrue: [objectMemory followForwarded: methArg]
ifFalse: [methArg].
(objectMemory isOopCompiledMethod: meth) ifFalse:
[^objectMemory nilObject].
classObj := self methodClassOf: meth.
(self addressCouldBeClassObj: classObj) ifTrue:
[classDict := objectMemory fetchPointer: MethodDictionaryIndex ofObject: classObj.
classDictSize := objectMemory fetchWordLengthOf: classDict.
methodArray := objectMemory fetchPointer: MethodArrayIndex ofObject: classDict.
i := 0.
[i <= (classDictSize - SelectorStart)] whileTrue:
[meth = (objectMemory fetchPointer: i ofObject: methodArray) ifTrue:
[^(objectMemory fetchPointer: i + SelectorStart ofObject: classDict)].
i := i + 1]].
^objectMemory nilObject!
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."
^(self literalCountOf: methodObj) + LiteralStart * BytesPerOop + 1!
Item was changed:
----- Method: StackInterpreter>>firstBytecodeOfAlternateHeader:method: (in category 'compiled methods') -----
firstBytecodeOfAlternateHeader: methodHeader method: theMethod
^theMethod + ((LiteralStart + (self literalCountOfAlternateHeader: methodHeader)) * BytesPerWord) + BaseHeaderSize!
Item was changed:
----- Method: StackInterpreter>>floatArg: (in category 'plugin primitive support') -----
floatArg: index
"Like #stackFloatValue: but access method arguments left-to-right"
| oop |
<returnTypeC: #double>
oop := self methodArg: index.
oop = 0 ifTrue:[^0.0]. "methodArg: failed"
^self floatValueOf: oop!
Item was changed:
----- Method: StackInterpreter>>flush (in category 'debug printing') -----
flush
<cmacro: '() fflush(stdout)'>!
Item was changed:
----- Method: StackInterpreter>>flushExternalPrimitiveOf: (in category 'plugin primitive support') -----
flushExternalPrimitiveOf: methodObj
"methodObj is a CompiledMethod containing an external primitive. Flush the function address and session ID of the CM"
| lit |
(self literalCountOf: methodObj) > 0 ifFalse:
[^nil]. "Something's broken"
lit := self literal: 0 ofMethod: methodObj.
((objectMemory isArray: lit) and:[(objectMemory lengthOf: lit) = 4]) ifFalse:
[^nil]. "Something's broken"
"ConstZero is a known SmallInt so no root check needed"
objectMemory storePointerUnchecked: 2 ofObject: lit withValue: ConstZero.
objectMemory storePointerUnchecked: 3 ofObject: lit withValue: ConstZero!
Item was changed:
----- Method: StackInterpreter>>flushExternalPrimitiveTable (in category 'plugin primitive support') -----
flushExternalPrimitiveTable
"Flush the external primitive table"
0 to: MaxExternalPrimitiveTableSize-1 do:[:i|
externalPrimitiveTable at: i put: 0].
externalPrimitiveTableFirstFreeIndex := 0!
Item was changed:
----- Method: StackInterpreter>>flushExternalPrimitives (in category 'plugin primitive support') -----
flushExternalPrimitives
"Flush the references to external functions from plugin primitives.
This will force a reload of those primitives when accessed next.
Note: We must flush the method cache here also, so that any failed
primitives are looked up again."
objectMemory allObjectsDo:
[:oop| | primIdx |
(objectMemory isFreeObject: oop) ifFalse:
[(objectMemory isCompiledMethod: oop) ifTrue: "This is a compiled method"
[primIdx := self primitiveIndexOf: oop.
primIdx = PrimitiveExternalCallIndex ifTrue: "It's primitiveExternalCall"
[self flushExternalPrimitiveOf: oop]]]].
self flushMethodCache.
self flushAtCache.
self flushExternalPrimitiveTable!
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 *'>
theFP + (self frameStackedReceiverOffset: theFP)
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: theFP + FoxReceiver
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 frameMethod: theFP)) not.
(self frameHasContext: theFP) ifTrue:
[self assert: (objectMemory isForwarded: (self frameContext: theFP)) not]!
Item was removed:
- ----- Method: StackInterpreter>>followNecessaryForwardingInMethod: (in category 'lazy become') -----
- followNecessaryForwardingInMethod: methodObj
- "To avoid any chance of a forwarded object during super sends we follow the
- methodClassAssociation. The forwarded object send fault only copes with
- normal sends to instances."
- | assoc classObj |
- assoc := self methodClassAssociationOf: methodObj.
- (objectMemory isForwarded: assoc) ifTrue:
- [assoc := objectMemory followForwarded: assoc.
- self setMethodClassAssociationOf: methodObj to: assoc].
- classObj := objectMemory fetchPointer: ValueIndex ofObject: assoc.
- (objectMemory isForwarded: classObj) ifTrue:
- [classObj := objectMemory followForwarded: assoc.
- objectMemory storePointer: ValueIndex ofObject: assoc withValue: classObj]!
Item was added:
+ ----- Method: StackInterpreter>>followNecessaryForwardingInMethod: (in category 'lazy become') -----
+ followNecessaryForwardingInMethod: methodObj
+ "To avoid any chance of a forwarded object during super sends we follow the
+ methodClassAssociation. The forwarded object send fault only copes with
+ normal sends to instances."
+ | assoc classObj |
+ assoc := self methodClassAssociationOf: methodObj.
+ (objectMemory isForwarded: assoc) ifTrue:
+ [assoc := objectMemory followForwarded: assoc.
+ self setMethodClassAssociationOf: methodObj to: assoc].
+ classObj := objectMemory fetchPointer: ValueIndex ofObject: assoc.
+ (objectMemory isForwarded: classObj) ifTrue:
+ [classObj := objectMemory followForwarded: assoc.
+ objectMemory storePointer: ValueIndex ofObject: assoc withValue: classObj]!
Item was changed:
----- Method: StackInterpreter>>frameCallerFP: (in category 'frame access') -----
frameCallerFP: theFP
<inline: true>
<var: #theFP type: #'char *'>
<returnTypeC: 'char *'>
^self pointerForOop: (stackPages longAt: theFP + FoxSavedFP)!
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) + BytesPerWord!
Item was changed:
----- Method: StackInterpreter>>frameContext: (in category 'frame access') -----
frameContext: theFP
<inline: true>
<var: #theFP type: #'char *'>
^stackPages longAt: theFP + FoxThisContext!
Item was changed:
----- Method: StackInterpreter>>frameIsBlockActivation: (in category 'frame access') -----
frameIsBlockActivation: theFP "<Integer>"
<inline: true>
<var: #theFP type: #'char *'>
^(stackPages byteAt: theFP + FoxFrameFlags + 3) ~= 0!
Item was changed:
----- Method: StackInterpreter>>frameMethod: (in category 'frame access') -----
frameMethod: theFP
<inline: true>
<var: #theFP type: #'char *'>
^stackPages longAt: theFP + FoxMethod!
Item was changed:
----- Method: StackInterpreter>>frameNumArgs: (in category 'frame access') -----
frameNumArgs: theFP
"See encodeFrameFieldHasContext:numArgs:"
<inline: true>
<var: #theFP type: #'char *'>
^stackPages byteAt: theFP + FoxFrameFlags + 1!
Item was changed:
----- Method: StackInterpreter>>frameStackedReceiverOffset: (in category 'frame access') -----
frameStackedReceiverOffset: theFP
"Answer the offset in bytes from the the frame pointer to its stacked receiver.
The receiver of a message send or the closure of a block activation is
always on the stack above any arguments and the frame itself. See the
diagram in StackInterpreter class>>initializeFrameIndices."
<inline: true>
<var: #theFP type: #'char *'>
^self frameStackedReceiverOffsetNumArgs: (self frameNumArgs: theFP)!
Item was changed:
----- Method: StackInterpreter>>functionForPrimitiveCallout (in category 'plugin primitive support') -----
functionForPrimitiveCallout
"Answer the function primitiveCallout from the FFI plugin or nil if it can't
be found. Cache it for performance. We use this circumlocution so that
Squeak can be deployed without the FFI plugin for security reasons."
<returnTypeC: 'void (*functionForPrimitiveCallout())(void)'>
| function |
<var: #function declareC: 'static void *function = (void *)-1'>
self cCode: '' inSmalltalk: [function := -1].
function asInteger = -1 ifTrue:
[function := self ioLoadFunction: 'primitiveCallout' From: 'SqueakFFIPrims'].
^self cCoerceSimple: function to: #'void (*)(void)'!
Item was changed:
----- Method: StackInterpreter>>getCodeCompactionMSecs (in category 'internal interpreter access') -----
getCodeCompactionMSecs
"This is nil in the StackVM"
^objectMemory nilObject!
Item was removed:
- ----- Method: StackInterpreter>>getCogVMFlags (in category 'internal interpreter access') -----
- getCogVMFlags
- "Answer an array of flags indicating various properties of the Cog VM.
- Bit 2: if set, implies preempting a process does not put it to the back of its run queue"
- ^objectMemory integerObjectOf: (preemptionYields ifTrue: [0] ifFalse: [4])!
Item was added:
+ ----- Method: StackInterpreter>>getCogVMFlags (in category 'internal interpreter access') -----
+ getCogVMFlags
+ "Answer an array of flags indicating various properties of the Cog VM.
+ Bit 2: if set, implies preempting a process does not put it to the back of its run queue"
+ ^objectMemory integerObjectOf: (preemptionYields ifTrue: [0] ifFalse: [4])!
Item was removed:
- ----- Method: StackInterpreter>>getDesiredCogCodeSize (in category 'internal interpreter access') -----
- getDesiredCogCodeSize
- "This is nil in the StackVM"
- ^objectMemory nilObject!
Item was added:
+ ----- Method: StackInterpreter>>getDesiredCogCodeSize (in category 'internal interpreter access') -----
+ getDesiredCogCodeSize
+ "This is nil in the StackVM"
+ ^objectMemory nilObject!
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) // BytesPerWord) ifTrue:
[^objectMemory fetchPointer: primFailCode - 1 ofObject: table]].
^objectMemory integerObjectOf: primFailCode!
Item was changed:
----- Method: StackInterpreter>>getFullScreenFlag (in category 'plugin primitive support') -----
getFullScreenFlag
^fullScreenFlag!
Item was changed:
----- Method: StackInterpreter>>getInterruptKeycode (in category 'plugin primitive support') -----
getInterruptKeycode
^interruptKeycode!
Item was changed:
----- Method: StackInterpreter>>getLongFromFile:swap: (in category 'image save/restore') -----
getLongFromFile: aFile swap: swapFlag
"Answer the next word read from aFile, byte-swapped according to the swapFlag."
| w |
<var: #aFile type: 'sqImageFile '>
w := 0.
self cCode: 'sqImageFileRead(&w, sizeof(w), 1, aFile)'.
swapFlag
ifTrue: [^ objectMemory byteSwapped: w]
ifFalse: [^ w].
!
Item was changed:
----- Method: StackInterpreter>>getSavedWindowSize (in category 'plugin primitive support') -----
getSavedWindowSize
^savedWindowSize!
Item was changed:
----- Method: StackInterpreter>>handleForwardedSelectorFaultFor: (in category 'message sending') -----
handleForwardedSelectorFaultFor: selectorOop
"Handle a send fault that is due to a send using a forwarded selector.
Unforward the selector and follow the current method and special
selectors array to unforward the source of the forwarded selector."
self assert: (objectMemory isOopForwarded: selectorOop).
objectMemory
followForwardedObjectFields: method
toDepth: 0;
followForwardedObjectFields: (objectMemory splObj: SpecialSelectors)
toDepth: 0.
^objectMemory followForwarded: selectorOop!
Item was changed:
----- Method: StackInterpreter>>handleForwardedSendFaultFor: (in category 'message sending') -----
handleForwardedSendFaultFor: 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."
| 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 * 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>>handleSpecialSelectorSendFaultFor:fp:sp: (in category 'message sending') -----
handleSpecialSelectorSendFaultFor: obj fp: theFP sp: theSP
"Handle a special send fault that may be due to a special selector
send accessing a forwarded object.
Unforward the object on the stack and in inst vars and answer its target."
<inline: false>
<var: #fp type: #'char *'>
<var: #sp type: #'char *'>
self assert: (objectMemory isOopForwarded: obj).
self followForwardedFrameContents: theFP stackPointer: theSP.
(objectMemory isPointers: (self frameReceiver: theFP)) ifTrue:
[objectMemory
followForwardedObjectFields: (self frameReceiver: theFP)
toDepth: 0].
^objectMemory followForwarded: obj!
Item was changed:
----- Method: StackInterpreter>>handleStackOverflowOrEventAllowContextSwitch: (in category 'message sending') -----
handleStackOverflowOrEventAllowContextSwitch: mayContextSwitch
"The stackPointer is below the stackLimit. This is either because of a
stack overflow or the setting of stackLimit to indicate a possible interrupt.
Check for interrupts and stackOverflow and deal with each appropriately.
Answer if a context switch occurred."
| switched |
<inline: false>
"If the stackLimit differs from the realStackLimit then the stackLimit
has been set to indicate an event or interrupt that needs servicing."
stackLimit = stackPage realStackLimit
ifTrue:
[self externalWriteBackHeadFramePointers.
switched := false]
ifFalse: [switched := self checkForEventsMayContextSwitch: mayContextSwitch].
self handleStackOverflow.
^switched!
Item was removed:
- ----- Method: StackInterpreter>>headerOf: (in category 'compiled methods') -----
- headerOf: methodPointer
- ^objectMemory fetchPointer: HeaderIndex ofObject: methodPointer!
Item was added:
+ ----- Method: StackInterpreter>>headerOf: (in category 'compiled methods') -----
+ headerOf: methodPointer
+ ^objectMemory fetchPointer: HeaderIndex ofObject: methodPointer!
Item was changed:
----- Method: StackInterpreter>>ifAppropriateCompileToNativeCode:selector: (in category 'message sending') -----
ifAppropriateCompileToNativeCode: aMethodObj selector: selector
"Convenient noop in the StackInterpreter e.g. for sendInvokeCallbackContext:"!
Item was changed:
----- Method: StackInterpreter>>ifBackwardsCheckForEvents: (in category 'jump bytecodes') -----
ifBackwardsCheckForEvents: offset
"Backward jump means we're in a loop; check for possible interrupts."
<inline: true>
(offset < 0
and: [localSP < stackLimit]) ifTrue:
[self externalizeIPandSP.
self checkForEventsMayContextSwitch: true.
self browserPluginReturnIfNeeded.
self internalizeIPandSP]!
Item was removed:
- ----- 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 + (self literalCountOf: aMethod)) * BytesPerOop)) + 1
- and: (objectMemory lengthOf: aMethod)).
- ^aMethod + ip + objectMemory baseHeaderSize - 2!
Item was added:
+ ----- 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 + (self literalCountOf: aMethod)) * BytesPerOop)) + 1
+ and: (objectMemory lengthOf: aMethod)).
+ ^aMethod + ip + objectMemory baseHeaderSize - 2!
Item was changed:
----- Method: StackInterpreter>>initialPCForHeader:method: (in category 'compiled methods') -----
initialPCForHeader: methodHeader method: theMethod
<api>
^theMethod
+ ((LiteralStart + (self literalCountOfHeader: methodHeader)) * BytesPerOop)
+ objectMemory baseHeaderSize!
Item was changed:
----- Method: StackInterpreter>>instVar:ofContext: (in category 'frame access') -----
instVar: offset ofContext: aContext
"Fetch an instance avriable from a maybe married context.
If the context is still married compute the value of the
relevant inst var from the spouse frame's state."
| spouseFP |
<var: #spouseFP type: #'char *'>
<var: #thePage type: #'StackPage *'>
<var: #theFPAbove type: #'char *'>
<inline: true>
self assert: offset < MethodIndex.
self assert: (objectMemory isContext: aContext).
(self isMarriedOrWidowedContext: aContext) ifFalse:
[^objectMemory fetchPointer: offset ofObject: aContext].
self writeBackHeadFramePointers.
(self isWidowedContext: aContext) ifTrue:
[^objectMemory fetchPointer: offset ofObject: aContext].
spouseFP := self frameOfMarriedContext: aContext.
offset = SenderIndex ifTrue:
[^self ensureCallerContext: spouseFP].
offset = StackPointerIndex ifTrue:
[self assert: ReceiverIndex + (self stackPointerIndexForFrame: spouseFP) < (objectMemory lengthOf: aContext).
^objectMemory integerObjectOf: (self stackPointerIndexForFrame: spouseFP)].
offset = InstructionPointerIndex ifTrue:
[| theIP thePage theFPAbove |
spouseFP = localFP
ifTrue: [theIP := self oopForPointer: localIP]
ifFalse:
[thePage := stackPages stackPageFor: spouseFP.
theFPAbove := self findFrameAbove: spouseFP inPage: thePage.
theIP := theFPAbove == 0
ifTrue: [stackPages longAt: thePage headSP]
ifFalse:[self oopForPointer: (self frameCallerSavedIP: theFPAbove)]].
^self contextInstructionPointer: theIP frame: spouseFP].
self error: 'bad index'.
^0!
Item was changed:
----- Method: StackInterpreter>>instVar:ofContext:put: (in category 'frame access') -----
instVar: index ofContext: aMarriedContext put: anOop
| theFP |
"Assign the field of a married context. The important case to optimize is
assigning the sender. We could also consider optimizing assiging the IP but
typically that is followed by an assignment to the stack pointer and we can't
efficiently assign the stack pointer because it involves moving frames around."
<inline: true>
self assert: (self isMarriedOrWidowedContext: aMarriedContext).
self writeBackHeadFramePointers.
(self isStillMarriedContext: aMarriedContext) ifFalse:
[objectMemory storePointer: index ofObject: aMarriedContext withValue: anOop.
index = StackPointerIndex ifTrue:
[self ensureContextIsExecutionSafeAfterAssignToStackPointer: aMarriedContext].
^nil].
theFP := self frameOfMarriedContext: aMarriedContext.
index == SenderIndex ifTrue:
[| thePage onCurrentPage |
thePage := stackPages stackPageFor: theFP.
self assert: stackPage = stackPages mostRecentlyUsedPage.
onCurrentPage := thePage = stackPage.
self storeSenderOfFrame: theFP withValue: anOop.
onCurrentPage
ifTrue:
[localFP := stackPage headFP.
localSP := stackPage headSP]
ifFalse:
[stackPages markStackPageMostRecentlyUsed: stackPage].
^nil].
self externalizeIPandSP.
self externalDivorceFrame: theFP andContext: aMarriedContext.
objectMemory storePointer: index ofObject: aMarriedContext withValue: anOop.
index = StackPointerIndex ifTrue:
[self ensureContextIsExecutionSafeAfterAssignToStackPointer: aMarriedContext].
self internalizeIPandSP.
"Assigning various fields can force a divorce which can change the stackPage."
stackPages markStackPageMostRecentlyUsed: stackPage.
self assertValidExecutionPointe: localIP asUnsignedInteger r: localFP s: localSP imbar: true line: #'__LINE__'!
Item was changed:
----- Method: StackInterpreter>>internalActivateNewMethod (in category 'message sending') -----
internalActivateNewMethod
| methodHeader numTemps rcvr errorCode |
<inline: true>
methodHeader := self headerOf: newMethod.
numTemps := self temporaryCountOfMethodHeader: methodHeader.
rcvr := self internalStackValue: argumentCount. "could new rcvr be set at point of send?"
self internalPush: localIP.
self internalPush: localFP.
localFP := localSP.
self internalPush: newMethod.
self setMethod: newMethod methodHeader: methodHeader.
self internalPush: (self
encodeFrameFieldHasContext: false
isBlock: false
numArgs: (self argumentCountOfMethodHeader: methodHeader)).
self internalPush: objectMemory nilObject. "FxThisContext field"
self internalPush: rcvr.
"Initialize temps..."
argumentCount + 1 to: numTemps do:
[:i | self internalPush: objectMemory nilObject].
"-1 to account for pre-increment in fetchNextBytecode"
localIP := self pointerForOop: (self initialPCForHeader: methodHeader method: newMethod) - 1.
(self methodHeaderHasPrimitive: methodHeader) ifTrue:
["Skip the CallPrimitive bytecode, if it's there, and store the error code if the method starts
with a long store temp. Strictly no need to skip the store because it's effectively a noop."
localIP := localIP + (self sizeOfCallPrimitiveBytecode: methodHeader).
primFailCode ~= 0 ifTrue:
[(objectMemory byteAt: localIP + 1)
= (self longStoreBytecodeForHeader: methodHeader) ifTrue:
[errorCode := self getErrorObjectFromPrimFailCode.
self internalStackTopPut: errorCode "nil if primFailCode == 1, or primFailCode"].
primFailCode := 0]].
self assert: (self frameNumArgs: localFP) == argumentCount.
self assert: (self frameIsBlockActivation: localFP) not.
self assert: (self frameHasContext: localFP) not.
"Now check for stack overflow or an event (interrupt, must scavenge, etc)."
localSP < stackLimit ifTrue:
[self externalizeIPandSP.
self handleStackOverflowOrEventAllowContextSwitch: (self canContextSwitchIfActivating: newMethod header: methodHeader).
self internalizeIPandSP]!
Item was changed:
----- Method: StackInterpreter>>internalExecuteNewMethod (in category 'message sending') -----
internalExecuteNewMethod
| succeeded |
<inline: true>
primitiveFunctionPointer ~= 0 ifTrue:
[self isPrimitiveFunctionPointerAnIndex ifTrue:
[^self internalQuickPrimitiveResponse].
self externalizeIPandSP.
succeeded := self slowPrimitiveResponse.
self internalizeIPandSP.
succeeded ifTrue:
[self browserPluginReturnIfNeeded.
^nil]].
"if not primitive, or primitive failed, activate the method"
^self internalActivateNewMethod!
Item was changed:
----- Method: StackInterpreter>>internalPop: (in category 'internal interpreter access') -----
internalPop: nItems
"In the StackInterpreter stacks grow down."
localSP := localSP + (nItems * BytesPerOop)!
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 + 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 - BytesPerOop) put: object!
Item was changed:
----- Method: StackInterpreter>>internalStackTopPut: (in category 'internal interpreter access') -----
internalStackTopPut: aValue
^stackPages longAtPointer: localSP put: aValue!
Item was changed:
----- Method: StackInterpreter>>internalStackValue: (in category 'internal interpreter access') -----
internalStackValue: offset
"In the StackInterpreter stacks grow down."
^stackPages longAtPointer: localSP + (offset * BytesPerOop)!
Item was changed:
----- Method: StackInterpreter>>is:KindOf: (in category 'plugin primitive support') -----
is: oop KindOf: className
"Support for external primitives."
| oopClass |
<var: #className type:#'char *'>
oopClass := objectMemory fetchClassOf: oop.
[oopClass = objectMemory nilObject] whileFalse:[
(self classNameOf: oopClass Is: className) ifTrue:[^true].
oopClass := self superclassOf: oopClass].
^false!
Item was changed:
----- Method: StackInterpreter>>is:MemberOf: (in category 'plugin primitive support') -----
is: oop MemberOf: className
"Support for external primitives"
| oopClass |
<var: #className type:#'char *'>
oopClass := objectMemory fetchClassOf: oop.
^(self classNameOf: oopClass Is: className)!
Item was changed:
----- Method: StackInterpreter>>isBaseFrame: (in category 'frame access') -----
isBaseFrame: theFP
"A base frame (first frame in a stack page) is so marked by having a null saved fp."
<inline: true>
<var: #theFP type: #'char *'>
^(stackPages longAt: theFP + FoxSavedFP) == 0!
Item was added:
+ ----- Method: StackInterpreter>>isCog (in category 'internal interpreter access') -----
+ isCog
+ ^false!
Item was removed:
- ----- Method: StackInterpreter>>isCog (in category 'internal interpreter access') -----
- isCog
- ^false!
Item was changed:
----- Method: StackInterpreter>>isMachineCodeFrame: (in category 'frame access') -----
isMachineCodeFrame: theFP
"For compatibility with CoInterpreter. Needed to avoid slowPrimitiveResponse
failing within ceSend:to:numArgs: et al with an unbalanced stack."
<var: #theFP type: #'char *'>
<inline: true>
^false!
Item was changed:
----- Method: StackInterpreter>>isMarriedOrWidowedContext: (in category 'frame access') -----
isMarriedOrWidowedContext: aContext
^objectMemory isIntegerObject: (objectMemory fetchPointer: SenderIndex ofObject: aContext)!
Item was changed:
----- Method: StackInterpreter>>isQuickPrimitiveIndex: (in category 'compiled methods') -----
isQuickPrimitiveIndex: anInteger
<api>
^anInteger between: 256 and: 519!
Item was changed:
----- Method: StackInterpreter>>isReadMediatedContextInstVarIndex: (in category 'frame access') -----
isReadMediatedContextInstVarIndex: index
"Reading the sender, instructionPointer and stackPointer inst vars of a context must take
account of potentially married contexts and fetch the state from the frame. method,
closureOrNil and receiver can safely be fetched from the context without checking."
<api>
<inline: true>
^index <= StackPointerIndex!
Item was changed:
----- Method: StackInterpreter>>isSingleContext: (in category 'frame access') -----
isSingleContext: aContext
^objectMemory isNonImmediate: (objectMemory fetchPointer: SenderIndex ofObject: aContext)!
Item was changed:
----- Method: StackInterpreter>>isStillMarriedContext: (in category 'frame access') -----
isStillMarriedContext: aContext
"Answer if aContext is married or widowed and still married.
If a context is widowed then turn it into a single dead context."
^(self isMarriedOrWidowedContext: aContext)
and: [(self isWidowedContext: aContext) not]!
Item was changed:
----- Method: StackInterpreter>>isWidowedContext: (in category 'frame access') -----
isWidowedContext: aOnceMarriedContext
"See if the argument is connected with a live frame or not.
If it is not, turn it into a bereaved single context."
| theFrame thePage shouldBeFrameCallerField |
<var: #theFrame type: #'char *'>
<var: #thePage type: #'StackPage *'>
<var: #shouldBeFrameCallerField type: #'char *'>
self assert: ((objectMemory isContext: aOnceMarriedContext)
and: [self isMarriedOrWidowedContext: aOnceMarriedContext]).
theFrame := self frameOfMarriedContext: aOnceMarriedContext.
thePage := stackPages stackPageFor: theFrame.
((stackPages isFree: thePage)
or: [theFrame < thePage headFP]) ifFalse:
["The frame pointer is within the bounds of a live page.
Now check if it matches a frame."
shouldBeFrameCallerField := self withoutSmallIntegerTags:
(objectMemory fetchPointer: InstructionPointerIndex
ofObject: aOnceMarriedContext).
((self frameCallerFP: theFrame) = shouldBeFrameCallerField
and: [(self frameMethodObject: theFrame) = (objectMemory fetchPointer: MethodIndex
ofObject: aOnceMarriedContext)
and: [(self frameHasContext: theFrame)
and: [(self frameContext: theFrame) = aOnceMarriedContext]]]) ifTrue:
["It is still married!!"
^false]].
"It is out of range or doesn't match the frame's context.
It is widowed. Time to wear black."
self markContextAsDead: aOnceMarriedContext.
^true!
Item was added:
+ ----- Method: StackInterpreter>>isWriteMediatedContextInstVarIndex: (in category 'frame access') -----
+ isWriteMediatedContextInstVarIndex: index
+ "Wrining any inst vars of a context must take account of potentially married contexts
+ and set the state in the frame. Inst vars in subclasses don't need mediation; subclasses
+ can't marry."
+ <api>
+ <inline: true>
+ ^index <= ReceiverIndex!
Item was removed:
- ----- Method: StackInterpreter>>isWriteMediatedContextInstVarIndex: (in category 'frame access') -----
- isWriteMediatedContextInstVarIndex: index
- "Wrining any inst vars of a context must take account of potentially married contexts
- and set the state in the frame. Inst vars in subclasses don't need mediation; subclasses
- can't marry."
- <api>
- <inline: true>
- ^index <= ReceiverIndex!
Item was added:
+ ----- Method: StackInterpreter>>jumplfFalseBy: (in category 'jump bytecodes') -----
+ jumplfFalseBy: offset
+ | boolean |
+ boolean := self internalStackTop.
+ boolean = objectMemory falseObject
+ ifTrue: [self jump: offset]
+ ifFalse:
+ [boolean = objectMemory trueObject ifFalse:
+ [^self internalMustBeBoolean].
+ self fetchNextBytecode].
+ self internalPop: 1!
Item was removed:
- ----- Method: StackInterpreter>>jumplfFalseBy: (in category 'jump bytecodes') -----
- jumplfFalseBy: offset
- | boolean |
- boolean := self internalStackTop.
- boolean = objectMemory falseObject
- ifTrue: [self jump: offset]
- ifFalse:
- [boolean = objectMemory trueObject ifFalse:
- [^self internalMustBeBoolean].
- self fetchNextBytecode].
- self internalPop: 1!
Item was removed:
- ----- Method: StackInterpreter>>justActivateNewMethod (in category 'message sending') -----
- justActivateNewMethod
- | methodHeader numArgs numTemps rcvr errorCode |
- <inline: true>
- methodHeader := self headerOf: newMethod.
- numTemps := self temporaryCountOfMethodHeader: methodHeader.
- numArgs := self argumentCountOfMethodHeader: methodHeader.
-
- rcvr := self stackValue: numArgs. "could new rcvr be set at point of send?"
-
- self push: instructionPointer.
- self push: framePointer.
- framePointer := stackPointer.
- self push: newMethod.
- self setMethod: newMethod methodHeader: methodHeader.
- self push: (self encodeFrameFieldHasContext: false isBlock: false numArgs: numArgs).
- self push: objectMemory nilObject. "FxThisContext field"
- self push: rcvr.
-
- "clear remaining temps to nil"
- numArgs+1 to: numTemps do:
- [:i | self push: objectMemory nilObject].
-
- instructionPointer := (self initialPCForHeader: methodHeader method: newMethod) - 1.
-
- (self methodHeaderHasPrimitive: methodHeader) ifTrue:
- ["Skip the CallPrimitive bytecode, if it's there, and store the error code if the method starts
- with a long store temp. Strictly no need to skip the store because it's effectively a noop."
- instructionPointer := instructionPointer + (self sizeOfCallPrimitiveBytecode: methodHeader).
- primFailCode ~= 0 ifTrue:
- [(objectMemory byteAt: instructionPointer + 1)
- = (self longStoreBytecodeForHeader: methodHeader) ifTrue:
- [errorCode := self getErrorObjectFromPrimFailCode.
- self stackTopPut: errorCode "nil if primFailCode == 1, or primFailCode"].
- primFailCode := 0]].
-
- ^methodHeader!
Item was added:
+ ----- Method: StackInterpreter>>justActivateNewMethod (in category 'message sending') -----
+ justActivateNewMethod
+ | methodHeader numArgs numTemps rcvr errorCode |
+ <inline: true>
+ methodHeader := self headerOf: newMethod.
+ numTemps := self temporaryCountOfMethodHeader: methodHeader.
+ numArgs := self argumentCountOfMethodHeader: methodHeader.
+
+ rcvr := self stackValue: numArgs. "could new rcvr be set at point of send?"
+
+ self push: instructionPointer.
+ self push: framePointer.
+ framePointer := stackPointer.
+ self push: newMethod.
+ self setMethod: newMethod methodHeader: methodHeader.
+ self push: (self encodeFrameFieldHasContext: false isBlock: false numArgs: numArgs).
+ self push: objectMemory nilObject. "FxThisContext field"
+ self push: rcvr.
+
+ "clear remaining temps to nil"
+ numArgs+1 to: numTemps do:
+ [:i | self push: objectMemory nilObject].
+
+ instructionPointer := (self initialPCForHeader: methodHeader method: newMethod) - 1.
+
+ (self methodHeaderHasPrimitive: methodHeader) ifTrue:
+ ["Skip the CallPrimitive bytecode, if it's there, and store the error code if the method starts
+ with a long store temp. Strictly no need to skip the store because it's effectively a noop."
+ instructionPointer := instructionPointer + (self sizeOfCallPrimitiveBytecode: methodHeader).
+ primFailCode ~= 0 ifTrue:
+ [(objectMemory byteAt: instructionPointer + 1)
+ = (self longStoreBytecodeForHeader: methodHeader) ifTrue:
+ [errorCode := self getErrorObjectFromPrimFailCode.
+ self stackTopPut: errorCode "nil if primFailCode == 1, or primFailCode"].
+ primFailCode := 0]].
+
+ ^methodHeader!
Item was changed:
----- Method: StackInterpreter>>literal:ofMethod: (in category 'compiled methods') -----
literal: offset ofMethod: methodPointer
<api>
^objectMemory fetchPointer: offset + LiteralStart ofObject: methodPointer
!
Item was changed:
----- Method: StackInterpreter>>literalCountOf: (in category 'compiled methods') -----
literalCountOf: methodPointer
^self literalCountOfHeader: (self headerOf: methodPointer)!
Item was changed:
----- Method: StackInterpreter>>literalCountOfAlternateHeader: (in category 'compiled methods') -----
literalCountOfAlternateHeader: headerPointer
<inline: true>
^(headerPointer >> 1) bitAnd: 16rFFFF!
Item was changed:
----- Method: StackInterpreter>>literalCountOfHeader: (in category 'compiled methods') -----
literalCountOfHeader: headerPointer
<api>
^self cppIf: MULTIPLEBYTECODESETS
ifTrue: [(self headerIndicatesAlternateBytecodeSet: headerPointer)
ifTrue: [self literalCountOfAlternateHeader: headerPointer]
ifFalse: [self literalCountOfOriginalHeader: headerPointer]]
ifFalse: [self literalCountOfOriginalHeader: headerPointer]!
Item was changed:
----- Method: StackInterpreter>>literalCountOfOriginalHeader: (in category 'compiled methods') -----
literalCountOfOriginalHeader: headerPointer
<inline: true>
^(headerPointer >> 10) bitAnd: 16rFF!
Item was changed:
----- Method: StackInterpreter>>log10: (in category 'debug printing') -----
log10: n
"compat with C library."
<doNotGenerate>
^n log: 10!
Item was changed:
----- Method: StackInterpreter>>longJumpIfFalse (in category 'jump bytecodes') -----
longJumpIfFalse
self jumplfFalseBy: ((currentBytecode bitAnd: 3) * 256) + self fetchByte.!
Item was changed:
----- Method: StackInterpreter>>longPushTemporaryVariableBytecode (in category 'stack bytecodes') -----
longPushTemporaryVariableBytecode
"230 11100110 i i i i i i i i Push Temporary Variable #iiiiiiii"
| index |
index := self fetchByte.
self fetchNextBytecode.
self internalPush: (self temporary: index in: localFP)!
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 fetchWordLengthOf: dictionary.
mask := length - SelectorStart - 1.
index := SelectorStart + (mask bitAnd: ((objectMemory isImmediate: selector)
ifTrue: [objectMemory integerValueOf: selector]
ifFalse: [objectMemory hashBitsOf: selector])).
"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].
nextSelector = selector ifTrue:
[methodArray := objectMemory fetchPointer: MethodArrayIndex ofObject: dictionary.
^objectMemory fetchPointer: 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: class ~= objectMemory nilObject.
currentClass := class.
[currentClass ~= objectMemory nilObject]
whileTrue:
[dictionary := objectMemory fetchPointer: MethodDictionaryIndex ofObject: currentClass.
dictionary = objectMemory nilObject ifTrue:
["MethodDict pointer is nil (hopefully due a swapped out stub)
-- raise exception #cannotInterpret:."
self createActualMessageTo: class.
messageSelector := objectMemory splObj: SelectorCannotInterpret.
self 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 + 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 fetchWordLengthOf: 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.
nextSelector = messageSelector ifTrue:
[methodArray := objectMemory fetchPointer: MethodArrayIndex ofObject: dictionary.
newMethod := objectMemory fetchPointer: index ofObject: methodArray.
^true].
index := index + 1].
^false].
index := SelectorStart + (mask bitAnd: ((objectMemory isImmediate: messageSelector)
ifTrue: [objectMemory integerValueOf: messageSelector]
ifFalse: [objectMemory hashBitsOf: messageSelector])).
"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].
nextSelector = messageSelector ifTrue:
[methodArray := objectMemory fetchPointer: MethodArrayIndex ofObject: dictionary.
newMethod := objectMemory fetchPointer: 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>>lookupMethodNoMNUEtcInClass: (in category 'callback support') -----
lookupMethodNoMNUEtcInClass: class
"Lookup messageSelector in class. Answer 0 on success. Answer the splObj: index
for the error selector to use on failure rather than performing MNU processing etc."
| currentClass dictionary |
<inline: true>
currentClass := class.
[currentClass ~= objectMemory nilObject] whileTrue:
[dictionary := objectMemory fetchPointer: MethodDictionaryIndex ofObject: currentClass.
dictionary = objectMemory nilObject ifTrue:
[lkupClass := self superclassOf: currentClass.
^SelectorCannotInterpret].
(self lookupMethodInDictionary: dictionary) ifTrue:
[self addNewMethodToCache: class.
^0].
currentClass := self superclassOf: currentClass].
lkupClass := class.
^SelectorDoesNotUnderstand!
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 |
<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 fetchPointer: MethodIndex ofObject: aContext.
(objectMemory isIntegerObject: theIP) ifFalse:
[self error: 'context is not resumable'].
theIP := objectMemory integerValueOf: theIP.
"If the frame is a closure activation then the closure should be on the stack in
the pushed receiver position (closures receiver the value[:value:] messages).
Otherwise it should be the receiver proper."
maybeClosure := objectMemory fetchPointer: ClosureIndex ofObject: aContext.
maybeClosure ~= objectMemory nilObject
ifTrue:
[numArgs := self argumentCountOfClosure: maybeClosure.
stackPages longAt: pointer put: maybeClosure]
ifFalse:
[| header |
header := self headerOf: theMethod.
numArgs := self argumentCountOfMethodHeader: header.
self cppIf: MULTIPLEBYTECODESETS
ifTrue: "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: (objectMemory fetchPointer: ReceiverIndex ofObject: aContext)].
"Put the arguments on the stack"
1 to: numArgs do:
[:i|
stackPages
longAt: (pointer := pointer - BytesPerWord)
put: (objectMemory fetchPointer: ReceiverIndex + i ofObject: aContext)].
"saved caller ip is sender context in base frame"
stackPages
longAt: (pointer := pointer - BytesPerWord)
put: (objectMemory fetchPointer: SenderIndex ofObject: aContext).
"base frame's saved fp is null"
stackPages
longAt: (pointer := pointer - BytesPerWord)
put: 0.
page baseFP: pointer; headFP: pointer.
stackPages
longAt: (pointer := pointer - BytesPerWord)
put: theMethod.
stackPages
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 - BytesPerWord)
put: aContext.
stackPages
longAt: (pointer := pointer - BytesPerWord)
put: (objectMemory fetchPointer: ReceiverIndex ofObject: aContext).
stackPtrIndex := self quickFetchInteger: StackPointerIndex ofObject: aContext.
self assert: ReceiverIndex + stackPtrIndex < (objectMemory lengthOf: aContext).
numArgs + 1 to: stackPtrIndex do:
[:i|
stackPages
longAt: (pointer := pointer - 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 - 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 validStackPageBaseFrames.
^page!
Item was removed:
- ----- Method: StackInterpreter>>mapInterpreterOops (in category 'object memory support') -----
- mapInterpreterOops
- "Map all oops in the interpreter's state to their new values
- during garbage collection or a become: operation."
- "Assume: All traced variables contain valid oops."
- self mapStackPages.
- self mapMachineCode.
- self mapTraceLogs.
- self mapVMRegisters.
- self mapProfileState.
- self remapCallbackState.
- (tempOop ~= 0
- and: [objectMemory shouldRemapOop: tempOop]) ifTrue:
- [tempOop := objectMemory remapObj: tempOop]!
Item was added:
+ ----- Method: StackInterpreter>>mapInterpreterOops (in category 'object memory support') -----
+ mapInterpreterOops
+ "Map all oops in the interpreter's state to their new values
+ during garbage collection or a become: operation."
+ "Assume: All traced variables contain valid oops."
+ self mapStackPages.
+ self mapMachineCode.
+ self mapTraceLogs.
+ self mapVMRegisters.
+ self mapProfileState.
+ self remapCallbackState.
+ (tempOop ~= 0
+ and: [objectMemory shouldRemapOop: tempOop]) ifTrue:
+ [tempOop := objectMemory remapObj: tempOop]!
Item was changed:
----- Method: StackInterpreter>>mapMachineCode (in category 'object memory support') -----
mapMachineCode
"This is a no-op in the StackVM"!
Item was changed:
----- Method: StackInterpreter>>mapTraceLogs (in category 'object memory support') -----
mapTraceLogs
"This is a no-op in the StackVM"!
Item was changed:
----- Method: StackInterpreter>>mapVMRegisters (in category 'object memory support') -----
mapVMRegisters
"Map the oops in the interpreter's vm ``registers'' to their new values
during garbage collection or a become: operation."
"Assume: All traced variables contain valid oops.
N.B. Don't trace messageSelector and lkupClass; these are ephemeral, live
only during message lookup and because createActualMessageTo will not
cause a GC these cannot change during message lookup."
(objectMemory shouldRemapObj: method) ifTrue:
[instructionPointer := instructionPointer - method. "*rel to method"
method := objectMemory remapObj: method.
instructionPointer := instructionPointer + method]. "*rel to method"
(objectMemory shouldRemapOop: newMethod) ifTrue: "maybe oop due to object-as-method"
[newMethod := objectMemory remapObj: newMethod]!
Item was changed:
----- Method: StackInterpreter>>markAndTraceInterpreterOops: (in category 'object memory support') -----
markAndTraceInterpreterOops: fullGCFlag
"Mark and trace all oops in the interpreter's state."
"Assume: All traced variables contain valid oops.
N.B. Don't trace messageSelector and lkupClass; these are ephemeral, live
only during message lookup and because createActualMessageTo will not
cause a GC these cannot change during message lookup."
| oop |
"Must mark stack pages first to initialize the per-page trace
flags for full garbage collect before any subsequent tracing."
self markAndTraceStackPages: fullGCFlag.
self markAndTraceTraceLog.
self markAndTracePrimTraceLog.
objectMemory markAndTrace: objectMemory specialObjectsOop. "also covers nilObj, trueObj, falseObj, and compact classes"
(objectMemory isImmediate: newMethod) ifFalse:
[objectMemory markAndTrace: newMethod].
self traceProfileState.
tempOop = 0 ifFalse: [objectMemory markAndTrace: tempOop].
1 to: objectMemory remapBufferCount do: [:i |
oop := objectMemory remapBuffer at: i.
(objectMemory isIntegerObject: oop) ifFalse: [objectMemory markAndTrace: oop]].
"Callback support - trace suspended callback list"
1 to: jmpDepth do:[:i|
oop := suspendedCallbacks at: i.
(objectMemory isIntegerObject: oop) ifFalse:[objectMemory markAndTrace: oop].
oop := suspendedMethods at: i.
(objectMemory isIntegerObject: oop) ifFalse:[objectMemory markAndTrace: oop].
]!
Item was changed:
----- Method: StackInterpreter>>markAndTracePrimTraceLog (in category 'object memory support') -----
markAndTracePrimTraceLog
"This is a no-op in the StackVM"!
Item was changed:
----- Method: StackInterpreter>>markAndTraceStackPage: (in category 'object memory support') -----
markAndTraceStackPage: thePage
| theSP theFP frameRcvrOffset callerFP oop |
<var: #thePage type: #'StackPage *'>
<var: #theSP type: #'char *'>
<var: #theFP type: #'char *'>
<var: #frameRcvrOffset type: #'char *'>
<var: #callerFP type: #'char *'>
<inline: false>
self assert: (stackPages isFree: thePage) not.
theSP := thePage headSP.
theFP := thePage headFP.
"Skip the instruction pointer on top of stack of inactive pages."
thePage = stackPage ifFalse:
[theSP := theSP + BytesPerWord].
[frameRcvrOffset := self frameReceiverOffset: theFP.
[theSP <= frameRcvrOffset] whileTrue:
[oop := stackPages longAt: theSP.
(objectMemory isIntegerObject: oop) ifFalse:
[objectMemory markAndTrace: oop].
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 + BytesPerWord.
theFP := callerFP].
theSP := theFP + FoxCallerSavedIP. "caller ip is frameCallerContext in a base frame"
[theSP <= thePage baseAddress] whileTrue:
[oop := stackPages longAt: theSP.
(objectMemory isIntegerObject: oop) ifFalse:
[objectMemory markAndTrace: oop].
theSP := theSP + BytesPerWord]!
Item was removed:
- ----- Method: StackInterpreter>>markAndTraceTraceLog (in category 'object memory support') -----
- markAndTraceTraceLog
- "This is a no-op in the StackVM"!
Item was added:
+ ----- Method: StackInterpreter>>markAndTraceTraceLog (in category 'object memory support') -----
+ markAndTraceTraceLog
+ "This is a no-op in the StackVM"!
Item was changed:
----- Method: StackInterpreter>>markContextAsDead: (in category 'frame access') -----
markContextAsDead: oop
"Mark the argument, which must be a context, married, widowed or single, as dead.
For married or widowed contexts this breaks any link to the spouse and makes the context single.
For all contexts, marks the context as inactive/having been returned from."
<inline: true>
self assert: (objectMemory isContext: oop).
objectMemory
storePointerUnchecked: SenderIndex ofObject: oop withValue: objectMemory nilObject;
storePointerUnchecked: InstructionPointerIndex ofObject: oop withValue: objectMemory nilObject!
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 * 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 + BytesPerWord].
"Finally check stacked receiver (closure field or duplicate of receiver) and arguments"
theSP := theFP + FoxCallerSavedIP + BytesPerWord.
rcvrOffset := theFP + (self frameStackedReceiverOffset: theFP).
[theSP <= rcvrOffset] whileTrue:
[anOop = (stackPages longAt: theSP) ifTrue:
[^true].
theSP := theSP + BytesPerWord].
^false!
Item was changed:
----- Method: StackInterpreter>>marryContextInNewStackPageAndInitializeInterpreterRegisters: (in category 'frame access') -----
marryContextInNewStackPageAndInitializeInterpreterRegisters: aContext
"Establish aContext at the base of a new stackPage, make the stackPage the
active one and set-up the interreter registers. This is used to boot the system
and bring it back after a snapshot."
<inline: false>
| newPage |
<var: #newPage type: #'StackPage *'>
self assert: stackPage = 0.
newPage := self makeBaseFrameFor: aContext.
self setStackPageAndLimit: newPage.
framePointer := stackPage headFP.
stackPointer := stackPage headSP.
self setMethod: (self iframeMethod: stackPage headFP).
instructionPointer := self popStack!
Item was added:
+ ----- Method: StackInterpreter>>maybeFlagMethodAsInterpreted: (in category 'compiled methods') -----
+ maybeFlagMethodAsInterpreted: aMethod
+ "Convenient noop in the StackInterpreter e.g. for sendInvokeCallbackContext:"!
Item was removed:
- ----- Method: StackInterpreter>>maybeFlagMethodAsInterpreted: (in category 'compiled methods') -----
- maybeFlagMethodAsInterpreted: aMethod
- "Convenient noop in the StackInterpreter e.g. for sendInvokeCallbackContext:"!
Item was changed:
----- Method: StackInterpreter>>methodClassOf: (in category 'compiled methods') -----
methodClassOf: methodPointer
^self cppIf: NewspeakVM
ifTrue:
[ | literal |
literal := self literal: (self literalCountOf: methodPointer) - 1 ofMethod: methodPointer.
literal = objectMemory nilObject
ifTrue: [literal]
ifFalse: [objectMemory fetchPointer: ValueIndex ofObject: literal]]
ifFalse:
[objectMemory fetchPointer: ValueIndex ofObject: (self literal: (self literalCountOf: methodPointer) - 1 ofMethod: methodPointer)]!
Item was changed:
----- Method: StackInterpreter>>methodHeaderHasPrimitive: (in category 'compiled methods') -----
methodHeaderHasPrimitive: methodHeader
"Note: We now have 10 bits of primitive index, but they are in two places
for temporary backward compatibility. The time to unpack is negligible,
since the derived primitive function pointer is stored in the method cache."
^self
cppIf: MULTIPLEBYTECODESETS
ifTrue: [(self headerIndicatesAlternateBytecodeSet: methodHeader)
ifTrue: [self alternateHeaderHasPrimitiveFlag: methodHeader]
ifFalse: [(methodHeader bitAnd: 16r200003FE) ~= 0]]
ifFalse: [(methodHeader bitAnd: 16r200003FE) ~= 0]!
Item was changed:
----- Method: StackInterpreter>>methodUsesAlternateBytecodeSet: (in category 'internal interpreter access') -----
methodUsesAlternateBytecodeSet: aMethodObj
<api>
<inline: true>
"A negative header selects the alternate bytecode set."
^self headerIndicatesAlternateBytecodeSet: (self headerOf: aMethodObj)!
Item was changed:
----- Method: StackInterpreter>>nacFetchStackPointerOf: (in category 'internal interpreter access') -----
nacFetchStackPointerOf: aContext
"A version of fetchStackPointerOf: for use when objects may be forwarded.
Does not do an assert-check of the stack pointer being in bounds."
| sp |
<inline: true>
sp := objectMemory fetchPointer: StackPointerIndex ofObject: aContext.
(objectMemory isIntegerObject: sp) ifFalse: [^0].
^objectMemory integerValueOf: sp!
Item was changed:
----- Method: StackInterpreter>>nameOfClass: (in category 'debug printing') -----
nameOfClass: classOop
"Brain-damaged nameOfClass: for C VM. Does *not* answer Foo class for metaclasses.
Use e.g. classIsMeta: to avoid being fooled."
<inline: false>
<returnTypeC: 'char *'>
(objectMemory sizeBitsOf: classOop) = metaclassSizeBits ifTrue:
[^self nameOfClass: (objectMemory fetchPointer: thisClassIndex ofObject: classOop)].
^objectMemory firstFixedField: (objectMemory fetchPointer: classNameIndex ofObject: classOop)!
Item was changed:
----- Method: StackInterpreter>>noAssertHeaderOf: (in category 'compiled methods') -----
noAssertHeaderOf: methodPointer
^objectMemory fetchPointer: HeaderIndex ofObject: methodPointer!
Item was changed:
----- Method: StackInterpreter>>noInlineTemporary:in: (in category 'internal interpreter access') -----
noInlineTemporary: offset in: theFP
<var: #theFP type: #'char *'>
<inline: false>
^self temporary: offset in: theFP!
Item was changed:
----- Method: StackInterpreter>>noInlineTemporary:in:put: (in category 'internal interpreter access') -----
noInlineTemporary: offset in: theFP put: valueOop
<var: #theFP type: #'char *'>
<inline: false>
^self temporary: offset in: theFP put: valueOop!
Item was added:
+ ----- Method: StackInterpreter>>objectMemory (in category 'cog jit support') -----
+ objectMemory
+ <doNotGenerate>
+ ^objectMemory!
Item was removed:
- ----- Method: StackInterpreter>>objectMemory (in category 'cog jit support') -----
- objectMemory
- <doNotGenerate>
- ^objectMemory!
Item was changed:
----- Method: StackInterpreter>>okayFields: (in category 'debug support') -----
okayFields: oop
"Check if the argument is an ok object.
If this is a pointers object, check that its fields are all okay oops."
| i fieldOop |
(oop = nil or: [oop = 0]) ifTrue: [ ^true ].
(objectMemory isIntegerObject: oop) ifTrue: [ ^true ].
(objectMemory okayOop: oop) ifFalse: [ ^false ].
(objectMemory oopHasOkayClass: oop) ifFalse: [ ^false ].
((objectMemory isPointersNonInt: oop) or: [objectMemory isCompiledMethod: oop]) ifFalse: [ ^true ].
(objectMemory isCompiledMethod: oop)
ifTrue:
[i := (self literalCountOf: oop) + LiteralStart - 1]
ifFalse:
[(objectMemory isContext: oop)
ifTrue: [i := CtxtTempFrameStart + (self fetchStackPointerOf: oop) - 1]
ifFalse: [i := (objectMemory lengthOf: oop) - 1]].
[i >= 0] whileTrue: [
fieldOop := objectMemory fetchPointer: i ofObject: oop.
(objectMemory isIntegerObject: fieldOop) ifFalse: [
(objectMemory okayOop: fieldOop) ifFalse: [ ^false ].
(self oopHasOkayClass: fieldOop) ifFalse: [ ^false ].
].
i := i - 1.
].
^true!
Item was changed:
----- Method: StackInterpreter>>pop: (in category 'internal interpreter access') -----
pop: nItems
<inline: true>
"In the StackInterpreter stacks grow down."
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) * 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) * BytesPerWord))
put: (objectMemory booleanObjectOf: trueOrFalse).
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) * BytesPerWord))
put: (objectMemory integerObjectOf: integerVal).
stackPointer := sp!
Item was changed:
----- Method: StackInterpreter>>popStackBytecode (in category 'stack bytecodes') -----
popStackBytecode
self fetchNextBytecode.
self internalPop: 1.
!
Item was changed:
----- Method: StackInterpreter>>postBecomeAction: (in category 'object memory support') -----
postBecomeAction: becomeEffectsFlags
becomeEffectsFlags ~= 0 ifTrue:
[self followForwardingPointersInStackZone: becomeEffectsFlags]!
Item was changed:
----- Method: StackInterpreter>>preBecomeAction (in category 'object memory support') -----
preBecomeAction
"Need to write back the frame pointers unless all pages are free (as in snapshot)"
stackPage ~= 0 ifTrue:
[self externalWriteBackHeadFramePointers]!
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]!
Item was changed:
----- Method: StackInterpreter>>primitiveIndexOfMethod:header: (in category 'compiled methods') -----
primitiveIndexOfMethod: theMethod header: methodHeader
"Note: With the Squeak V0 format we now have 10 bits of primitive index, but they are in
two places for temporary backward compatibility. The time to unpack is negligible,
since the derived primitive function pointer is stored in the method cache. With the new
format we assume a 3-byte CallPrimitive with a little-endian 16-bit primitive index."
<api>
<inline: true>
^self cppIf: MULTIPLEBYTECODESETS
ifTrue:
[(self headerIndicatesAlternateBytecodeSet: methodHeader)
ifTrue:
[(self alternateHeaderHasPrimitiveFlag: methodHeader)
ifTrue:
[| firstBytecode |
firstBytecode := self firstBytecodeOfAlternateHeader: methodHeader method: theMethod.
(objectMemory byteAt: firstBytecode + 1) + ((objectMemory byteAt: firstBytecode + 2) << 8)]
ifFalse:
[0]]
ifFalse:
[| primBits |
primBits := methodHeader >> 1.
(primBits bitAnd: 16r1FF) + (primBits >> 19 bitAnd: 16r200)]]
ifFalse:
[| primBits |
primBits := methodHeader >> 1.
(primBits bitAnd: 16r1FF) + (primBits >> 19 bitAnd: 16r200)]!
Item was added:
+ ----- Method: StackInterpreter>>printActivationNameForMethod:startClass:isBlock:firstTemporary: (in category 'debug printing') -----
+ printActivationNameForMethod: aMethod startClass: startClass isBlock: isBlock firstTemporary: maybeMessage
+ | methClass methodSel |
+ <inline: false>
+ isBlock ifTrue:
+ [self print: '[] in '].
+ self findSelectorAndClassForMethod: aMethod
+ lookupClass: startClass
+ do: [:sel :class|
+ methodSel := sel.
+ methClass := class].
+ ((self addressCouldBeOop: startClass) and: [methClass notNil])
+ ifTrue:
+ [startClass = methClass
+ ifTrue: [self printNameOfClass: methClass count: 5]
+ ifFalse:
+ [self printNameOfClass: startClass count: 5.
+ self printChar: $(.
+ self printNameOfClass: methClass count: 5.
+ self printChar: $)]]
+ ifFalse: [self print: 'INVALID CLASS'].
+ self printChar: $>.
+ (objectMemory addressCouldBeOop: methodSel)
+ ifTrue:
+ [(objectMemory isBytes: methodSel)
+ ifTrue: [self printStringOf: methodSel]
+ ifFalse: [self printOopShort: methodSel]]
+ ifFalse: [self print: 'INVALID SELECTOR'].
+ (methodSel = (objectMemory splObj: SelectorDoesNotUnderstand)
+ and: [(objectMemory addressCouldBeObj: maybeMessage)
+ and: [(objectMemory fetchClassOfNonImm: maybeMessage) = (objectMemory splObj: ClassMessage)]]) ifTrue:
+ ["print arg message selector"
+ methodSel := objectMemory fetchPointer: MessageSelectorIndex ofObject: maybeMessage.
+ self print: ' '.
+ self printStringOf: methodSel]!
Item was removed:
- ----- Method: StackInterpreter>>printActivationNameForMethod:startClass:isBlock:firstTemporary: (in category 'debug printing') -----
- printActivationNameForMethod: aMethod startClass: startClass isBlock: isBlock firstTemporary: maybeMessage
- | methClass methodSel |
- <inline: false>
- isBlock ifTrue:
- [self print: '[] in '].
- self findSelectorAndClassForMethod: aMethod
- lookupClass: startClass
- do: [:sel :class|
- methodSel := sel.
- methClass := class].
- ((self addressCouldBeOop: startClass) and: [methClass notNil])
- ifTrue:
- [startClass = methClass
- ifTrue: [self printNameOfClass: methClass count: 5]
- ifFalse:
- [self printNameOfClass: startClass count: 5.
- self printChar: $(.
- self printNameOfClass: methClass count: 5.
- self printChar: $)]]
- ifFalse: [self print: 'INVALID CLASS'].
- self printChar: $>.
- (objectMemory addressCouldBeOop: methodSel)
- ifTrue:
- [(objectMemory isBytes: methodSel)
- ifTrue: [self printStringOf: methodSel]
- ifFalse: [self printOopShort: methodSel]]
- ifFalse: [self print: 'INVALID SELECTOR'].
- (methodSel = (objectMemory splObj: SelectorDoesNotUnderstand)
- and: [(objectMemory addressCouldBeObj: maybeMessage)
- and: [(objectMemory fetchClassOfNonImm: maybeMessage) = (objectMemory splObj: ClassMessage)]]) ifTrue:
- ["print arg message selector"
- methodSel := objectMemory fetchPointer: MessageSelectorIndex ofObject: maybeMessage.
- self print: ' '.
- self printStringOf: methodSel]!
Item was changed:
----- Method: StackInterpreter>>printActivationNameForSelector:startClass: (in category 'debug printing') -----
printActivationNameForSelector: aSelector startClass: startClass
| methClass |
<inline: false>
(objectMemory addressCouldBeObj: startClass)
ifTrue:
[self findClassForSelector: aSelector
lookupClass: startClass
do: [:class| methClass := class].
(methClass isNil or: [startClass = methClass])
ifTrue:
[self printNameOfClass: methClass count: 5.
self printChar: $>.
methClass ifNil:
[self printStringOf: (objectMemory splObj: SelectorDoesNotUnderstand).
self print: ' ']]
ifFalse:
[self printNameOfClass: startClass count: 5.
self printChar: $(.
self printNameOfClass: methClass count: 5.
self printChar: $).
self printChar: $>]]
ifFalse: [self print: 'INVALID CLASS'].
(objectMemory addressCouldBeOop: aSelector)
ifTrue:
[(objectMemory isBytes: aSelector)
ifTrue: [self printStringOf: aSelector]
ifFalse: [self printOopShort: aSelector]]
ifFalse: [self print: 'INVALID SELECTOR']!
Item was changed:
----- Method: StackInterpreter>>printCallStack (in category 'debug printing') -----
printCallStack
<inline: false>
framePointer = nil
ifTrue: [self printCallStackOf: (objectMemory fetchPointer: SuspendedContextIndex ofObject: self activeProcess)]
ifFalse: [self printCallStackFP: framePointer]!
Item was changed:
----- Method: StackInterpreter>>printCallStackFP: (in category 'debug printing') -----
printCallStackFP: theFP
| context |
<inline: false>
<var: #theFP type: #'char *'>
context := self shortReversePrintFrameAndCallers: theFP.
[context = objectMemory nilObject] whileFalse:
[(self isMarriedOrWidowedContext: context)
ifTrue:
[(self checkIsStillMarriedContext: context currentFP: framePointer) ifFalse:
[self shortPrintContext: context.
^nil].
context := self shortReversePrintFrameAndCallers: (self frameOfMarriedContext: context)]
ifFalse:
[context := self printContextCallStackOf: context]]!
Item was changed:
----- Method: StackInterpreter>>printCallStackOf:currentFP: (in category 'debug printing') -----
printCallStackOf: aContext currentFP: currFP
| ctxt theFP thePage |
<inline: false>
<var: #currFP type: #'char *'>
<var: #theFP type: #'char *'>
<var: #thePage type: #'StackPage *'>
ctxt := aContext.
[ctxt = objectMemory nilObject] whileFalse:
[(self isMarriedOrWidowedContext: ctxt)
ifFalse:
[self shortPrintContext: ctxt.
ctxt := objectMemory fetchPointer: SenderIndex ofObject: ctxt]
ifTrue:
[theFP := self frameOfMarriedContext: ctxt.
(self checkIsStillMarriedContext: ctxt currentFP: currFP)
ifTrue:
[thePage := stackPages stackPageFor: theFP.
(stackPages isFree: thePage) ifTrue:
[self printHexPtr: theFP; print: ' is on a free page?!!'; cr.
^nil].
self shortPrintFrameAndCallers: theFP.
theFP := thePage baseFP.
ctxt := self frameCallerContext: theFP]
ifFalse: [self print: 'widowed caller frame '; printHexPtr: theFP; cr.
^nil]]]!
Item was changed:
----- Method: StackInterpreter>>printChar: (in category 'debug printing') -----
printChar: aByte
<api>
"For testing in Smalltalk, this method should be overridden in a subclass."
self putchar: aByte.!
Item was changed:
----- Method: StackInterpreter>>printContextCallStackOf: (in category 'debug printing') -----
printContextCallStackOf: aContext
"Print the call stack of aContext until it links to a frame."
| ctxt |
<inline: false>
ctxt := aContext.
[ctxt = objectMemory nilObject or: [self isMarriedOrWidowedContext: ctxt]] whileFalse:
[self shortPrintContext: ctxt.
ctxt := objectMemory fetchPointer: SenderIndex ofObject: ctxt].
^ctxt!
Item was changed:
----- Method: StackInterpreter>>printFloat: (in category 'debug printing') -----
printFloat: f
"For testing in Smalltalk, this method should be overridden in a subclass."
<cmacro: '(f) printf("%g", f)'>
self print: f!
Item was changed:
----- Method: StackInterpreter>>printFrame: (in category 'debug printing') -----
printFrame: theFP
| thePage theSP |
<inline: false>
<var: #theFP type: #'char *'>
<var: #thePage type: #'StackPage *'>
<var: #theSP type: #'char *'>
theFP = framePointer
ifTrue: [theSP := stackPointer]
ifFalse:
[thePage := stackPages stackPageFor: theFP.
(stackPages isFree: thePage) ifTrue:
[self printHexPtr: theFP; print: ' is on a free page?!!'; cr.
^nil].
theSP := self findSPOrNilOf: theFP
on: thePage
startingFrom: ((thePage = stackPage
and: [framePointer < thePage headFP])
ifTrue: [framePointer]
ifFalse: [thePage headFP])].
theSP isNil ifTrue:
[self print: 'could not find sp; using bogus value'; cr.
theSP := theFP + FoxReceiver].
self printFrame: theFP WithSP: theSP!
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) * BytesPerWord).
numArgs to: 1 by: -1 do:
[: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 - BytesPerWord to: theSP + BytesPerWord by: BytesPerWord negated do:
[:addr|
self printFrameOop: 'temp/stck' at: addr].
self printFrameThing: 'frame ip' at: theSP]
ifFalse:
[theFP + FoxReceiver - BytesPerWord to: theSP by: BytesPerWord negated do:
[:addr|
self printFrameOop: 'temp/stck' at: addr]]!
Item was changed:
----- Method: StackInterpreter>>printFrameAndCallers:SP: (in category 'debug printing') -----
printFrameAndCallers: theFP SP: theSP
self printFrameAndCallers: theFP SP: theSP short: false!
Item was changed:
----- Method: StackInterpreter>>printFrameAndCallers:SP:short: (in category 'debug printing') -----
printFrameAndCallers: theFP SP: theSP short: printShort
<inline: false>
<var: #theFP type: #'char *'>
<var: #theSP type: #'char *'>
(stackPages couldBeFramePointer: theFP) ifFalse: [^nil].
(self isBaseFrame: theFP) ifFalse:
[self printFrameAndCallers: (self frameCallerFP: theFP)
SP: (self frameCallerSP: theFP)
short: printShort].
printShort ifTrue:
[self shortPrintFrame: theFP.
^nil].
self cr.
self printFrame: theFP WithSP: theSP!
Item was changed:
----- Method: StackInterpreter>>printFrameFlagsForFP: (in category 'debug printing') -----
printFrameFlagsForFP: theFP
| address it |
<inline: false>
<var: #theFP type: #'char *'>
<var: #address type: #'char *'>
address := theFP + FoxFrameFlags.
it := stackPages longAt: address.
self printHexPtr: address;
print: ': flags: ';
printHex: it.
it ~= 0 ifTrue:
[self printChar: $=; printNum: it].
self print: ' numArgs: '; printNum: (self frameNumArgs: theFP);
print: ((self frameHasContext: theFP) ifTrue: [' hasContext'] ifFalse: [' noContext']);
print: ((self frameIsBlockActivation: theFP) ifTrue: [' isBlock'] ifFalse: [' notBlock']);
cr!
Item was changed:
----- Method: StackInterpreter>>printFrameOop:index:at: (in category 'debug printing') -----
printFrameOop: name index: idx at: address
| it |
<inline: false>
<var: #name type: #'char *'>
<var: #address type: #'char *'>
it := stackPages longAt: address.
self printHexPtr: address;
printChar: $:.
1 to: 11 - (self strlen: name) - (self log10: (idx max: 1)) floor
do: [:i| self printChar: $ ].
self print: name;
printNum: idx;
print: ': ';
printHex: it;
tab;
printChar: $=;
printOopShort: it;
cr!
Item was changed:
----- Method: StackInterpreter>>printHeadFrame (in category 'debug printing') -----
printHeadFrame
<inline: false>
self printFrame: localFP WithSP: localSP!
Item was changed:
----- Method: StackInterpreter>>printHex: (in category 'debug printing') -----
printHex: n
"Print n in hex, in the form ' 0x1234', padded to a width of 10 characters
in 32-bits ('0x' + 8 nibbles) or 18 characters in 64-bits ('0x' + 16 nibbles)"
<api>
| len buf |
<var: #buf declareC: 'char buf[35]'> "large enough for a 64-bit value in hex plus the null plus 16 spaces"
self cCode: 'memset(buf,'' '',34)' inSmalltalk: [buf := 'doh!!'].
len := self cCode: 'sprintf(buf + 2 + 2 * BytesPerWord, "0x%lx", (unsigned long)(n))'.
self cCode: 'printf("%s", buf + len)'.
len touch: buf!
Item was changed:
----- Method: StackInterpreter>>printHexPtr: (in category 'debug printing') -----
printHexPtr: p
"Print p in hex, padded to 10 characters in the form ' 0x1234'"
<inline: true>
<var: #p type: #'void *'>
self printHex: (self oopForPointer: p)!
Item was changed:
----- Method: StackInterpreter>>printHexPtrnp: (in category 'debug printing') -----
printHexPtrnp: p
"Print p in hex, unpadded, in the form '0x1234'"
<inline: true>
<var: #p type: #'void *'>
self printHexnp: (self oopForPointer: p)!
Item was changed:
----- Method: StackInterpreter>>printMethodCache (in category 'debug printing') -----
printMethodCache
0 to: MethodCacheSize - 1 by: MethodCacheEntrySize do:
[:i | | s c m p |
s := methodCache at: i + MethodCacheSelector.
c := methodCache at: i + MethodCacheClass.
m := methodCache at: i + MethodCacheMethod.
p := methodCache at: i + MethodCachePrimFunction.
((objectMemory addressCouldBeOop: s)
and: [c ~= 0
and: [(self addressCouldBeClassObj: c)
or: [self addressCouldBeClassObj: (objectMemory classForClassTag: c)]]]) ifTrue:
[self transcript ensureCr.
self print: i; cr; tab.
(objectMemory isBytesNonImm: s)
ifTrue: [self printHex: s; space; print: (self stringOf: s); cr]
ifFalse: [self shortPrintOop: s].
self tab.
(self addressCouldBeClassObj: c)
ifTrue: [self shortPrintOop: c]
ifFalse: [self printNum: c; space; shortPrintOop: (objectMemory classForClassTag: c)].
self tab; shortPrintOop: m; tab.
p isSymbol
ifTrue: [self print: p]
ifFalse: [self printNum: p].
self cr]]!
Item was changed:
----- Method: StackInterpreter>>printMethodHeaderOop: (in category 'debug printing') -----
printMethodHeaderOop: anOop
"Override hook for CoInterpreter"
<inline: true>
^self printOopShort: anOop!
Item was changed:
----- Method: StackInterpreter>>printNameOfClass:count: (in category 'debug printing') -----
printNameOfClass: classOop count: cnt
"Details: The count argument is used to avoid a possible infinite recursion if classOop is a corrupted object."
<inline: false>
(classOop isNil or: [classOop = 0 or: [cnt <= 0]]) ifTrue: [^self print: 'bad class'].
((objectMemory sizeBitsOf: classOop) = metaclassSizeBits
and: [metaclassSizeBits > (thisClassIndex * BytesPerOop)]) "(Metaclass instSize * 4)"
ifTrue: [self printNameOfClass: (objectMemory fetchPointer: thisClassIndex ofObject: classOop) count: cnt - 1.
self print: ' class']
ifFalse: [self printStringOf: (objectMemory fetchPointer: classNameIndex ofObject: classOop)]!
Item was changed:
----- Method: StackInterpreter>>printOop: (in category 'debug printing') -----
printOop: oop
| cls fmt lastIndex startIP bytecodesPerLine 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: [' is not on the heap']); cr.
^nil].
(objectMemory isFreeObject: oop) ifTrue:
[self print: ' is a free chunk of size '; printNum: (objectMemory sizeOfFree: oop); cr.
^nil].
(objectMemory isForwarded: oop) ifTrue:
[self
print: ' is a forwarded object to '; printHex: (objectMemory followForwarded: oop);
print: ' of slot size '; printNum: (objectMemory numSlotsOfAny: oop); cr.
^nil].
self print: ': a(n) '.
self printNameOfClass: (cls := objectMemory fetchClassOfNonImm: oop) count: 5.
cls = (objectMemory splObj: ClassFloat) ifTrue:
[self cr; printFloat: (self dbgFloatValueOf: oop); cr.
^nil].
fmt := objectMemory formatOf: oop.
fmt > objectMemory lastPointerFormat ifTrue:
[self print: ' nbytes '; printNum: (objectMemory byteLengthOf: 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.
^nil].
(objectMemory isWords: oop) ifTrue:
[lastIndex := 64 min: ((objectMemory byteLengthOf: 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]].
^nil].
^self printStringOf: oop; cr].
"this is nonsense. apologies."
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 * 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+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>>printOopShort: (in category 'debug printing') -----
printOopShort: oop
<inline: false>
self printOopShortInner: oop.
self flush!
Item was changed:
----- Method: StackInterpreter>>printStackCallStack (in category 'debug printing') -----
printStackCallStack
<doNotGenerate>
| theFP context |
theFP := localFP.
[context := self shortReversePrintFrameAndCallers: theFP.
((self isMarriedOrWidowedContext: context)
and: [self checkIsStillMarriedContext: context currentFP: localFP]) ifFalse:
[^nil].
theFP := self frameOfMarriedContext: context] repeat!
Item was changed:
----- Method: StackInterpreter>>printStackPage: (in category 'debug printing') -----
printStackPage: page
<inline: false>
<var: #page type: #'StackPage *'>
self print: 'page '; printHexPtr: (self cCode: [page] inSmalltalk: [page baseAddress]);
print: ' ('; printNum: (stackPages pageIndexFor: page realStackLimit);
print: ') (trace: '; printNum: page trace; printChar: $).
(stackPages isFree: page) ifTrue:
[self print: ' (free)'].
page = stackPages mostRecentlyUsedPage ifTrue:
[self print: ' (MRU)'].
self cr; tab; print: 'ba: ';
printHexPtr: page baseAddress; print: ' - sl: ';
printHexPtr: page realStackLimit; print: ' - sl-so: ';
printHexPtr: page realStackLimit - self stackLimitOffset; print: ' - la:';
printHexPtr: page lastAddress.
(stackPages isFree: page) ifFalse:
[self cr; tab; print: 'baseFP '; printHexPtr: page baseFP.
self "cr;" tab; print: 'headFP '; printHexPtr: page headFP.
self "cr;" tab; print: 'headSP '; printHexPtr: page headSP].
self cr; tab; print: 'prev '; printHexPtr: (self cCode: 'page->prevPage' inSmalltalk: [page prevPage baseAddress]);
print: ' ('; printNum: (stackPages pageIndexFor: page prevPage realStackLimit); printChar: $).
self tab; print: 'next '; printHexPtr: (self cCode: 'page->nextPage' inSmalltalk: [page nextPage baseAddress]);
print: ' ('; printNum: (stackPages pageIndexFor: page nextPage realStackLimit); printChar: $).
self cr!
Item was changed:
----- Method: StackInterpreter>>printStackPages (in category 'debug printing') -----
printStackPages
0 to: numStackPages - 1 do:
[:i|
self printStackPage: (stackPages stackPageAt: i).
self cr]!
Item was changed:
----- Method: StackInterpreter>>printStackPagesInUse (in category 'debug printing') -----
printStackPagesInUse
0 to: numStackPages - 1 do:
[:i|
(stackPages isFree: (stackPages stackPageAt: i)) ifFalse:
[self printStackPage: (stackPages stackPageAt: i).
self cr]]!
Item was changed:
----- Method: StackInterpreter>>printStringOf: (in category 'debug printing') -----
printStringOf: oop
| fmt len cnt max i |
<inline: false>
(objectMemory isImmediate: oop) ifTrue:
[^nil].
(objectMemory addressCouldBeObj: oop) ifFalse:
[^nil].
fmt := objectMemory formatOf: oop.
fmt < objectMemory firstByteFormat ifTrue: [^nil].
cnt := (max := 128) min: (len := objectMemory lengthOf: oop).
i := 0.
((objectMemory is: oop
instanceOf: (objectMemory splObj: ClassByteArray)
compactClassIndex: classByteArrayCompactIndex)
or: [(self isInstanceOfClassLargePositiveInteger: oop)
or: [(self isInstanceOfClassLargeNegativeInteger: oop)]])
ifTrue:
[[i < cnt] whileTrue:
[self printHex: (objectMemory fetchByte: i ofObject: oop).
i := i + 1]]
ifFalse:
[[i < cnt] whileTrue:
[self printChar: (objectMemory fetchByte: i ofObject: oop).
i := i + 1]].
len > max ifTrue:
[self print: '...'].
self flush!
Item was changed:
----- Method: StackInterpreter>>push: (in category 'internal interpreter access') -----
push: object
"In the StackInterpreter stacks grow down."
| sp |
<inline: true>
<var: #sp type: #'char *'>
stackPages longAt: (sp := stackPointer - BytesPerWord) put: object.
stackPointer := sp!
Item was changed:
----- Method: StackInterpreter>>pushBool: (in category 'internal interpreter access') -----
pushBool: trueOrFalse
<inline: true>
self push: (objectMemory booleanObjectOf: trueOrFalse)!
Item was added:
+ ----- 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 * BytesPerOop).
+ newClosure := self
+ closureIn: context
+ numArgs: numArgs
+ 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 removed:
- ----- 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 * BytesPerOop).
- newClosure := self
- closureIn: context
- numArgs: numArgs
- 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>>pushConstantNilBytecode (in category 'stack bytecodes') -----
pushConstantNilBytecode
self fetchNextBytecode.
self internalPush: objectMemory nilObject.
!
Item was changed:
----- Method: StackInterpreter>>pushConstantOneBytecode (in category 'stack bytecodes') -----
pushConstantOneBytecode
self fetchNextBytecode.
self internalPush: ConstOne.
!
Item was removed:
- ----- Method: StackInterpreter>>pushConstantTrueBytecode (in category 'stack bytecodes') -----
- pushConstantTrueBytecode
-
- self fetchNextBytecode.
- self internalPush: objectMemory trueObject.
- !
Item was added:
+ ----- Method: StackInterpreter>>pushConstantTrueBytecode (in category 'stack bytecodes') -----
+ pushConstantTrueBytecode
+
+ self fetchNextBytecode.
+ self internalPush: objectMemory trueObject.
+ !
Item was changed:
----- Method: StackInterpreter>>pushConstantZeroBytecode (in category 'stack bytecodes') -----
pushConstantZeroBytecode
self fetchNextBytecode.
self internalPush: ConstZero.
!
Item was changed:
----- Method: StackInterpreter>>pushExplicitOuterSendReceiverBytecode (in category 'stack bytecodes') -----
pushExplicitOuterSendReceiverBytecode
"Find the appropriate implicit receiver for outer N"
| litIndex n anIntOop |
<inline: true>
litIndex := self fetchByte.
anIntOop := self literal: litIndex.
n := (objectMemory isIntegerObject: anIntOop)
ifTrue: [objectMemory integerValueOf: anIntOop]
ifFalse: [0].
self fetchNextBytecode.
self internalPush:(self
explicitOuterReceiver: n
withObject: self receiver
withMixin: (self methodClassOf: method))!
Item was added:
+ ----- Method: StackInterpreter>>pushImplicitReceiverBytecode (in category 'stack bytecodes') -----
+ pushImplicitReceiverBytecode
+ "This bytecode is used to implement outer sends in NS2/NS3. The
+ bytecode takes as an argument the literal offset of a selector. It
+ effectively finds the nearest lexically-enclosing implementation of
+ that selector by searching up the static chain of the receiver,
+ starting at the current method."
+ | selector |
+ selector := self literal: self fetchByte.
+ self fetchNextBytecode.
+ self internalPush: (self
+ implicitReceiverFor: self receiver
+ mixin: (self methodClassOf: method)
+ implementing: selector)!
Item was removed:
- ----- Method: StackInterpreter>>pushImplicitReceiverBytecode (in category 'stack bytecodes') -----
- pushImplicitReceiverBytecode
- "This bytecode is used to implement outer sends in NS2/NS3. The
- bytecode takes as an argument the literal offset of a selector. It
- effectively finds the nearest lexically-enclosing implementation of
- that selector by searching up the static chain of the receiver,
- starting at the current method."
- | selector |
- selector := self literal: self fetchByte.
- self fetchNextBytecode.
- self internalPush: (self
- implicitReceiverFor: self receiver
- mixin: (self methodClassOf: method)
- implementing: selector)!
Item was changed:
----- Method: StackInterpreter>>pushInteger: (in category 'internal interpreter access') -----
pushInteger: integerValue
self push: (objectMemory integerObjectOf: integerValue).
^nil!
Item was changed:
----- Method: StackInterpreter>>pushLiteralConstant: (in category 'stack bytecodes') -----
pushLiteralConstant: literalIndex
self internalPush: (self literal: literalIndex).!
Item was changed:
----- Method: StackInterpreter>>pushLiteralVariable16CasesBytecode (in category 'stack bytecodes') -----
pushLiteralVariable16CasesBytecode
<expandCases>
self
cCode: "this bytecode will be expanded so that refs to currentBytecode below will be constant"
[self fetchNextBytecode.
self pushLiteralVariable: (currentBytecode bitAnd: 16rF)]
inSmalltalk: "Interpreter version has fetchNextBytecode out of order"
[self pushLiteralVariable: (currentBytecode bitAnd: 16rF).
self fetchNextBytecode]!
Item was changed:
----- Method: StackInterpreter>>pushReceiverVariable: (in category 'stack bytecodes') -----
pushReceiverVariable: fieldIndex
self internalPush: (objectMemory fetchPointer: fieldIndex ofObject: self receiver).!
Item was changed:
----- Method: StackInterpreter>>pushRemoteTemp:inVectorAt: (in category 'stack bytecodes') -----
pushRemoteTemp: index inVectorAt: tempVectorIndex
| tempVector |
tempVector := self temporary: tempVectorIndex in: localFP.
self internalPush: (objectMemory fetchPointer: index ofObject: tempVector)!
Item was added:
+ ----- Method: StackInterpreter>>pushRemoteTempLongBytecode (in category 'stack bytecodes') -----
+ pushRemoteTempLongBytecode
+ | remoteTempIndex tempVectorIndex |
+ remoteTempIndex := self fetchByte.
+ tempVectorIndex := self fetchByte.
+ self fetchNextBytecode.
+ self pushRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex!
Item was removed:
- ----- Method: StackInterpreter>>pushRemoteTempLongBytecode (in category 'stack bytecodes') -----
- pushRemoteTempLongBytecode
- | remoteTempIndex tempVectorIndex |
- remoteTempIndex := self fetchByte.
- tempVectorIndex := self fetchByte.
- self fetchNextBytecode.
- self pushRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex!
Item was removed:
- ----- Method: StackInterpreter>>pushTemporaryVariableBytecode (in category 'stack bytecodes') -----
- pushTemporaryVariableBytecode
- <expandCases>
- self
- cCode: "this bytecode will be expanded so that refs to currentBytecode below will be constant"
- [self fetchNextBytecode.
- self pushTemporaryVariable: (currentBytecode bitAnd: 16rF)]
- inSmalltalk: "Interpreter version has fetchNextBytecode out of order"
- [self pushTemporaryVariable: (currentBytecode bitAnd: 16rF).
- self fetchNextBytecode]!
Item was added:
+ ----- Method: StackInterpreter>>pushTemporaryVariableBytecode (in category 'stack bytecodes') -----
+ pushTemporaryVariableBytecode
+ <expandCases>
+ self
+ cCode: "this bytecode will be expanded so that refs to currentBytecode below will be constant"
+ [self fetchNextBytecode.
+ self pushTemporaryVariable: (currentBytecode bitAnd: 16rF)]
+ inSmalltalk: "Interpreter version has fetchNextBytecode out of order"
+ [self pushTemporaryVariable: (currentBytecode bitAnd: 16rF).
+ self fetchNextBytecode]!
Item was changed:
----- Method: StackInterpreter>>putLong:toFile: (in category 'image save/restore') -----
putLong: aWord toFile: aFile
"Append aWord to aFile in this platforms 'natural' byte order. (Bytes will be swapped, if
necessary, when the image is read on a different platform.) Set successFlag to false if
the write fails."
| objectsWritten |
<var: #aFile type: 'sqImageFile '>
objectsWritten := self cCode: 'sqImageFileWrite(&aWord, sizeof(aWord), 1, aFile)'.
self success: objectsWritten = 1.
!
Item was changed:
----- Method: StackInterpreter>>putShort:toFile: (in category 'image save/restore') -----
putShort: aShort toFile: aFile
"Append the 16-bit aShort to aFile in this platforms 'natural' byte order.
(Bytes will be swapped, if necessary, when the image is read on a
different platform.) Set successFlag to false if the write fails."
| objectsWritten |
<var: #aFile type: 'sqImageFile '>
objectsWritten := self cCode: 'sqImageFileWrite(&aShort, sizeof(short), 1, aFile)'.
self success: objectsWritten = 1.
!
Item was changed:
----- Method: StackInterpreter>>readImageFromFile:HeapSize:StartingAt: (in category 'image save/restore') -----
readImageFromFile: f HeapSize: desiredHeapSize StartingAt: imageOffset
"Read an image from the given file stream, allocating the given amount of memory to its object heap. Fail if the image has an unknown format or requires more than the given amount of memory."
"Details: This method detects when the image was stored on a machine with the opposite byte ordering from this machine and swaps the bytes automatically. Furthermore, it allows the header information to start 512 bytes into the file, since some file transfer programs for the Macintosh apparently prepend a Mac-specific header of this size. Note that this same 512 bytes of prefix area could also be used to store an exec command on Unix systems, allowing one to launch Smalltalk by invoking the image name as a command."
"This code is based on C code by Ian Piumarta and Smalltalk code by Tim Rowledge. Many thanks to both of you!!!!"
| swapBytes headerStart headerSize dataSize oldBaseAddr hdrNumStackPages
minimumMemory memStart bytesRead bytesToShift heapSize hdrEdenBytes
headerFlags hdrMaxExtSemTabSize |
<var: #f type: 'sqImageFile '>
<var: #memStart type: 'usqInt'>
<var: #desiredHeapSize type: 'usqInt'>
<var: #headerStart type: 'squeakFileOffsetType '>
<var: #dataSize type: 'size_t '>
<var: #imageOffset type: 'squeakFileOffsetType '>
metaclassSizeBits := 6 * BytesPerWord. "guess (Metaclass instSize * BPW)"
swapBytes := self checkImageVersionFrom: f startingAt: imageOffset.
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.
Preserve it to be polite to images run on Cog."
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].
"decrease Squeak object heap to leave extra memory for the VM"
heapSize := self cCode: 'reserveExtraCHeapBytes(desiredHeapSize, extraVMMemory)'.
"compare memory requirements with availability".
minimumMemory := dataSize + objectMemory edenBytes + self interpreterAllocationReserveBytes.
heapSize < minimumMemory ifTrue:
[self insufficientMemorySpecifiedError].
"allocate a contiguous block of memory for the Squeak heap"
objectMemory memory: (self
allocateMemory: heapSize
minimum: minimumMemory
imageFile: f
headerSize: headerSize) asUnsignedInteger.
objectMemory memory = nil ifTrue: [self insufficientMemoryAvailableError].
memStart := objectMemory startOfMemory.
objectMemory setMemoryLimit: (memStart + heapSize) - 24. "decrease memoryLimit a tad for safety"
objectMemory setEndOfMemory: memStart + dataSize.
"position file after the header"
self sqImageFile: f Seek: headerStart + headerSize.
"read in the image in bulk, then swap the bytes if necessary"
bytesRead := self cCode: 'sqImageFileRead(pointerForOop(memory), sizeof(unsigned char), dataSize, f)'.
bytesRead ~= dataSize ifTrue: [self unableToReadImageError].
self ensureImageFormatIsUpToDate: swapBytes.
"compute difference between old and new memory base addresses"
bytesToShift := memStart - oldBaseAddr.
self initializeInterpreter: bytesToShift. "adjusts all oops to new location"
^dataSize
!
Item was changed:
----- Method: StackInterpreter>>readableFormat: (in category 'image save/restore') -----
readableFormat: imageVersion
"Anwer true if images of the given format are readable by this interpreter.
Allows a virtual machine to accept selected older image formats."
^imageVersion = self imageFormatVersion "Float words in platform-order"
or: [imageVersion = self imageFormatCompatibilityVersion] "Float words in BigEndian order"!
Item was changed:
----- Method: StackInterpreter>>receiver (in category 'internal interpreter access') -----
receiver
<inline: true>
^stackPages longAt: localFP + FoxReceiver!
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) + 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) - BytesPerWord.
framePointer := theFP]
ifFalse:
[thePage := self makeBaseFrameFor: calloutContext.
framePointer := thePage headFP.
stackPointer := thePage headSP].
instructionPointer := self popStack.
self setStackPageAndLimit: thePage.
^true!
Item was removed:
- ----- Method: StackInterpreter>>removeProcess:fromList: (in category 'process primitive support') -----
- removeProcess: aProcess fromList: aList
- "Remove a given process from a linked list. May fail if aProcess is not on the list."
- | firstLink lastLink nextLink tempLink |
- firstLink := objectMemory fetchPointer: FirstLinkIndex ofObject: aList.
- lastLink := objectMemory fetchPointer: LastLinkIndex ofObject: aList.
- aProcess = firstLink ifTrue:[
- nextLink := objectMemory fetchPointer: NextLinkIndex ofObject: aProcess .
- objectMemory storePointer: FirstLinkIndex ofObject: aList withValue: nextLink.
- aProcess = lastLink ifTrue:[
- objectMemory storePointer: LastLinkIndex ofObject: aList withValue: objectMemory nilObject.
- ].
- ] ifFalse:[
- tempLink := firstLink.
- [tempLink = objectMemory nilObject ifTrue:[^self success: false]. "fail"
- nextLink := objectMemory fetchPointer: NextLinkIndex ofObject: tempLink.
- nextLink = aProcess] whileFalse:[
- tempLink := objectMemory fetchPointer: NextLinkIndex ofObject: tempLink.
- ].
- nextLink := objectMemory fetchPointer: NextLinkIndex ofObject: aProcess.
- objectMemory storePointer: NextLinkIndex ofObject: tempLink withValue: nextLink.
- aProcess = lastLink ifTrue:[
- objectMemory storePointer: LastLinkIndex ofObject: aList withValue: tempLink.
- ].
- ].
- objectMemory storePointer: NextLinkIndex ofObject: aProcess withValue: objectMemory nilObject!
Item was added:
+ ----- Method: StackInterpreter>>removeProcess:fromList: (in category 'process primitive support') -----
+ removeProcess: aProcess fromList: aList
+ "Remove a given process from a linked list. May fail if aProcess is not on the list."
+ | firstLink lastLink nextLink tempLink |
+ firstLink := objectMemory fetchPointer: FirstLinkIndex ofObject: aList.
+ lastLink := objectMemory fetchPointer: LastLinkIndex ofObject: aList.
+ aProcess = firstLink ifTrue:[
+ nextLink := objectMemory fetchPointer: NextLinkIndex ofObject: aProcess .
+ objectMemory storePointer: FirstLinkIndex ofObject: aList withValue: nextLink.
+ aProcess = lastLink ifTrue:[
+ objectMemory storePointer: LastLinkIndex ofObject: aList withValue: objectMemory nilObject.
+ ].
+ ] ifFalse:[
+ tempLink := firstLink.
+ [tempLink = objectMemory nilObject ifTrue:[^self success: false]. "fail"
+ nextLink := objectMemory fetchPointer: NextLinkIndex ofObject: tempLink.
+ nextLink = aProcess] whileFalse:[
+ tempLink := objectMemory fetchPointer: NextLinkIndex ofObject: tempLink.
+ ].
+ nextLink := objectMemory fetchPointer: NextLinkIndex ofObject: aProcess.
+ objectMemory storePointer: NextLinkIndex ofObject: tempLink withValue: nextLink.
+ aProcess = lastLink ifTrue:[
+ objectMemory storePointer: LastLinkIndex ofObject: aList withValue: tempLink.
+ ].
+ ].
+ objectMemory storePointer: NextLinkIndex ofObject: aProcess withValue: objectMemory nilObject!
Item was removed:
- ----- Method: 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) + 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) - BytesPerWord.
- framePointer := theFP]
- ifFalse:
- [thePage := self makeBaseFrameFor: calloutMethodContext.
- framePointer := thePage headFP.
- stackPointer := thePage headSP].
- instructionPointer := self popStack.
- self setStackPageAndLimit: thePage.
- self restoreCStackStateForCallbackContext: vmCallbackContext.
- "N.B. siglongjmp is defines as _longjmp on non-win32 platforms.
- This matches the use of _setjmp in ia32abicc.c."
- self siglong: vmCallbackContext trampoline jmp: (self integerValueOf: returnTypeOop).
- "NOTREACHED"
- ^true!
Item was added:
+ ----- Method: StackInterpreter>>returnAs:ThroughCallback:Context: (in category 'callback support') -----
+ returnAs: returnTypeOop ThroughCallback: vmCallbackContext Context: callbackMethodContext
+ "callbackMethodContext is an activation of invokeCallback:[stack:registers:jmpbuf:].
+ Its sender is the VM's state prior to the callback. Reestablish that state (via longjmp),
+ and mark callbackMethodContext as dead."
+ <export: true>
+ <var: #vmCallbackContext type: #'VMCallbackContext *'>
+ | calloutMethodContext theFP thePage |
+ <var: #theFP type: #'char *'>
+ <var: #thePage type: #'StackPage *'>
+ ((self isIntegerObject: returnTypeOop)
+ and: [self isLiveContext: callbackMethodContext]) ifFalse:
+ [^false].
+ calloutMethodContext := self externalInstVar: SenderIndex ofContext: callbackMethodContext.
+ (self isLiveContext: calloutMethodContext) ifFalse:
+ [^false].
+ "We're about to leave this stack page; must save the current frame's instructionPointer."
+ self push: instructionPointer.
+ self externalWriteBackHeadFramePointers.
+ "Mark callbackMethodContext as dead; the common case is that it is the current frame.
+ We go the extra mile for the debugger."
+ (self isSingleContext: callbackMethodContext)
+ ifTrue: [self markContextAsDead: callbackMethodContext]
+ ifFalse:
+ [theFP := self frameOfMarriedContext: callbackMethodContext.
+ framePointer = theFP "common case"
+ ifTrue:
+ [(self isBaseFrame: theFP)
+ ifTrue: [stackPages freeStackPage: stackPage]
+ ifFalse: "calloutMethodContext is immediately below on the same page. Make it current."
+ [instructionPointer := (self frameCallerSavedIP: framePointer) asUnsignedInteger.
+ stackPointer := framePointer + (self frameStackedReceiverOffset: framePointer) + 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) - BytesPerWord.
+ framePointer := theFP]
+ ifFalse:
+ [thePage := self makeBaseFrameFor: calloutMethodContext.
+ framePointer := thePage headFP.
+ stackPointer := thePage headSP].
+ instructionPointer := self popStack.
+ self setStackPageAndLimit: thePage.
+ self restoreCStackStateForCallbackContext: vmCallbackContext.
+ "N.B. siglongjmp is defines as _longjmp on non-win32 platforms.
+ This matches the use of _setjmp in ia32abicc.c."
+ self siglong: vmCallbackContext trampoline jmp: (self integerValueOf: returnTypeOop).
+ "NOTREACHED"
+ ^true!
Item was removed:
- ----- 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 + 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 added:
+ ----- 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 + 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 removed:
- ----- Method: StackInterpreter>>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."
- <export: true>
- | classTag |
- classTag := self fetchClassTagOfNonImm: (self splObj: ClassAlien).
- messageSelector := self splObj: SelectorInvokeCallback.
- argumentCount := 4.
- (self lookupInMethodCacheSel: messageSelector classTag: classTag) ifFalse:
- [(self lookupMethodNoMNUEtcInClass: (objectMemory classForClassTag: classTag)) ~= 0 ifTrue:
- [^false]].
- ((self argumentCountOf: newMethod) = 4
- and: [primitiveFunctionPointer = 0]) ifFalse:
- [^false].
- self push: (self splObj: ClassAlien). "receiver"
- self push: (self positive32BitIntegerFor: thunkPtr).
- self push: (self positive32BitIntegerFor: stackPtr).
- self push: (self positive32BitIntegerFor: regsPtr).
- self push: (self positive32BitIntegerFor: jmpBufPtr).
- 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 added:
+ ----- Method: StackInterpreter>>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."
+ <export: true>
+ | classTag |
+ classTag := self fetchClassTagOfNonImm: (self splObj: ClassAlien).
+ messageSelector := self splObj: SelectorInvokeCallback.
+ argumentCount := 4.
+ (self lookupInMethodCacheSel: messageSelector classTag: classTag) ifFalse:
+ [(self lookupMethodNoMNUEtcInClass: (objectMemory classForClassTag: classTag)) ~= 0 ifTrue:
+ [^false]].
+ ((self argumentCountOf: newMethod) = 4
+ and: [primitiveFunctionPointer = 0]) ifFalse:
+ [^false].
+ self push: (self splObj: ClassAlien). "receiver"
+ self push: (self positive32BitIntegerFor: thunkPtr).
+ self push: (self positive32BitIntegerFor: stackPtr).
+ self push: (self positive32BitIntegerFor: regsPtr).
+ self push: (self positive32BitIntegerFor: jmpBufPtr).
+ 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>>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: 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 added:
+ ----- Method: StackInterpreter>>sendLiteralSelector1ArgBytecode (in category 'send bytecodes') -----
+ sendLiteralSelector1ArgBytecode
+ "Can use any of the first 16 literals for the selector."
+ | rcvr |
+ messageSelector := self literal: (currentBytecode bitAnd: 16rF).
+ argumentCount := 1.
+ rcvr := self internalStackValue: 1.
+ lkupClassTag := objectMemory fetchClassTagOf: rcvr.
+ self assert: lkupClassTag ~= objectMemory nilObject.
+ self commonSend!
Item was removed:
- ----- Method: StackInterpreter>>sendLiteralSelector1ArgBytecode (in category 'send bytecodes') -----
- sendLiteralSelector1ArgBytecode
- "Can use any of the first 16 literals for the selector."
- | rcvr |
- messageSelector := self literal: (currentBytecode bitAnd: 16rF).
- argumentCount := 1.
- rcvr := self internalStackValue: 1.
- lkupClassTag := objectMemory fetchClassTagOf: rcvr.
- self assert: lkupClassTag ~= objectMemory nilObject.
- self commonSend!
Item was changed:
----- Method: StackInterpreter>>setBreakSelector: (in category 'debug support') -----
setBreakSelector: aString
<api>
<var: #aString type: #'char *'>
aString isNil
ifTrue: [breakSelectorLength := -1. "nil's effective length is zero" breakSelector := nil]
ifFalse: [breakSelectorLength := self strlen: aString. breakSelector := aString]!
Item was changed:
----- Method: StackInterpreter>>setCogVMFlags: (in category 'internal interpreter access') -----
setCogVMFlags: flags
"Set an array of flags indicating various properties of the Cog VM.
Bit 2: if set, implies preempting a process does not put it to the back of its run queue"
flags asUnsignedInteger > 7 ifTrue:
[^self primitiveFailFor: PrimErrUnsupported].
preemptionYields := (flags bitAnd: 4) = 0!
Item was changed:
----- Method: StackInterpreter>>setFrameContext:to: (in category 'frame access') -----
setFrameContext: theFP to: aContext
<inline: true>
<var: #theFP type: #'char *'>
stackPages longAt: theFP + FoxThisContext put: aContext!
Item was changed:
----- Method: StackInterpreter>>setImageHeaderFlagsFrom: (in category 'image save/restore') -----
setImageHeaderFlagsFrom: headerFlags
"Set the flags that are contained in the 7th long of the image header."
imageHeaderFlags := headerFlags. "so as to preserve unrecognised flags."
fullScreenFlag := headerFlags bitAnd: 1.
imageFloatsBigEndian := (headerFlags bitAnd: 2) = 0 ifTrue: [1] ifFalse: [0].
preemptionYields := (headerFlags bitAnd: 16) = 0!
Item was added:
+ ----- Method: StackInterpreter>>setInterruptKeycode: (in category 'plugin primitive support') -----
+ setInterruptKeycode: value
+ interruptKeycode := value!
Item was removed:
- ----- Method: StackInterpreter>>setInterruptKeycode: (in category 'plugin primitive support') -----
- setInterruptKeycode: value
- interruptKeycode := value!
Item was changed:
----- Method: StackInterpreter>>setInterruptPending: (in category 'plugin primitive support') -----
setInterruptPending: value
self forceInterruptCheck.
interruptPending := value!
Item was changed:
----- Method: StackInterpreter>>setMethod: (in category 'internal interpreter access') -----
setMethod: aMethodObj
"Set the method and determine the bytecode set based on the method header's sign.
If MULTIPLEBYTECODESETS then a negative header selects the alternate bytecode set.
Conditionalizing the code on MULTIPLEBYTECODESETS allows the header sign bit to be
used for other experiments."
<inline: true>
method := aMethodObj.
self assert: (objectMemory isOopCompiledMethod: method).
self cppIf: MULTIPLEBYTECODESETS
ifTrue: [bytecodeSetSelector := (self methodUsesAlternateBytecodeSet: method)
ifTrue: [256]
ifFalse: [0]]!
Item was removed:
- ----- Method: StackInterpreter>>setMethod:methodHeader: (in category 'internal interpreter access') -----
- setMethod: aMethodObj methodHeader: methodHeader
- "Set the method and determine the bytecode set based on the method header's sign.
- If MULTIPLEBYTECODESETS then a negative header selects the alternate bytecode set.
- Conditionalizing the code on MULTIPLEBYTECODESETS allows the header sign bit to be
- used for other experiments."
- <inline: true>
- method := aMethodObj.
- self assert: (objectMemory isOopCompiledMethod: method).
- self assert: (self headerOf: method) = methodHeader.
- self cppIf: MULTIPLEBYTECODESETS
- ifTrue: [bytecodeSetSelector := (self headerIndicatesAlternateBytecodeSet: methodHeader)
- ifTrue: [256]
- ifFalse: [0]]!
Item was added:
+ ----- Method: StackInterpreter>>setMethod:methodHeader: (in category 'internal interpreter access') -----
+ setMethod: aMethodObj methodHeader: methodHeader
+ "Set the method and determine the bytecode set based on the method header's sign.
+ If MULTIPLEBYTECODESETS then a negative header selects the alternate bytecode set.
+ Conditionalizing the code on MULTIPLEBYTECODESETS allows the header sign bit to be
+ used for other experiments."
+ <inline: true>
+ method := aMethodObj.
+ self assert: (objectMemory isOopCompiledMethod: method).
+ self assert: (self headerOf: method) = methodHeader.
+ self cppIf: MULTIPLEBYTECODESETS
+ ifTrue: [bytecodeSetSelector := (self headerIndicatesAlternateBytecodeSet: methodHeader)
+ ifTrue: [256]
+ ifFalse: [0]]!
Item was changed:
----- Method: StackInterpreter>>setMethodClassAssociationOf:to: (in category 'compiled methods') -----
setMethodClassAssociationOf: methodPointer to: anObject
objectMemory
storePointer: (self literalCountOf: methodPointer) + LiteralStart - 1
ofObject: methodPointer
withValue: anObject!
Item was changed:
----- Method: StackInterpreter>>setNextWakeupUsecs: (in category 'plugin primitive support') -----
setNextWakeupUsecs: value
<api>
<var: #value type: #usqLong>
nextWakeupUsecs := value!
Item was changed:
----- Method: StackInterpreter>>setTraceFlagOnContextsFramesPageIfNeeded: (in category 'object memory support') -----
setTraceFlagOnContextsFramesPageIfNeeded: aContext
| thePage |
<var: #thePage type: #'StackPage *'>
(self isStillMarriedContext: aContext) ifTrue:
[thePage := stackPages stackPageFor: (self frameOfMarriedContext: aContext).
self assert: (thePage trace between: 0 and: 2).
thePage trace = 0 ifTrue:
[thePage trace: 1]]!
Item was changed:
----- Method: StackInterpreter>>shortConditionalJumpFalse (in category 'jump bytecodes') -----
shortConditionalJumpFalse
self jumplfFalseBy: (currentBytecode bitAnd: 7) + 1!
Item was changed:
----- Method: StackInterpreter>>shortPrintContext: (in category 'debug printing') -----
shortPrintContext: aContext
| theFP |
<inline: false>
<var: #theFP type: #'char *'>
(objectMemory isContext: aContext) ifFalse:
[self printHex: aContext; print: ' is not a context'; cr.
^nil].
self printHex: aContext.
(self isMarriedOrWidowedContext: aContext)
ifTrue: [(self checkIsStillMarriedContext: aContext currentFP: framePointer)
ifTrue:
[(self isMachineCodeFrame: (theFP := self frameOfMarriedContext: aContext))
ifTrue: [self print: ' M (']
ifFalse: [self print: ' I ('].
self printHex: theFP asUnsignedInteger; print: ') ']
ifFalse:
[self print: ' w ']]
ifFalse: [self print: ' s '].
(self findHomeForContext: aContext)
ifNil: [self print: ' BOGUS CONTEXT (can''t determine home)']
ifNotNil:
[:home|
self printActivationNameFor: (objectMemory fetchPointer: MethodIndex ofObject: aContext)
receiver: (home isNil
ifTrue: [objectMemory nilObject]
ifFalse: [objectMemory fetchPointer: ReceiverIndex ofObject: home])
isBlock: home ~= aContext
firstTemporary: (objectMemory fetchPointer: 0 + CtxtTempFrameStart ofObject: home)].
self cr!
Item was changed:
----- Method: StackInterpreter>>shortPrintFrame: (in category 'debug printing') -----
shortPrintFrame: theFP
<inline: false>
<var: #theFP type: #'char *'>
| rcvr |
(stackPages couldBeFramePointer: theFP) ifFalse:
[self print: 'invalid frame pointer'; cr.
^nil].
rcvr := self frameReceiver: theFP.
self printHexPtr: theFP.
self space.
self printActivationNameFor: (self frameMethod: theFP)
receiver: rcvr
isBlock: (self frameIsBlockActivation: theFP)
firstTemporary: (self temporary: 0 in: theFP).
self space.
self shortPrintOop: rcvr "shortPrintOop: adds a cr"!
Item was changed:
----- Method: StackInterpreter>>shortPrintFrameAndCallers: (in category 'debug printing') -----
shortPrintFrameAndCallers: theFP
<inline: false>
<var: #theFP type: #'char *'>
(stackPages couldBeFramePointer: theFP) ifFalse: [^nil].
self shortPrintFrame: theFP.
(self isBaseFrame: theFP) ifFalse:
[self shortPrintFrameAndCallers: (self frameCallerFP: theFP)]!
Item was removed:
- ----- Method: StackInterpreter>>shortPrintFramesInCurrentPage (in category 'debug printing') -----
- shortPrintFramesInCurrentPage
- <inline: false>
- self shortPrintFrameAndCallers: localFP!
Item was added:
+ ----- Method: StackInterpreter>>shortPrintFramesInCurrentPage (in category 'debug printing') -----
+ shortPrintFramesInCurrentPage
+ <inline: false>
+ self shortPrintFrameAndCallers: localFP!
Item was removed:
- ----- Method: StackInterpreter>>shortPrintFramesInPage: (in category 'debug printing') -----
- shortPrintFramesInPage: thePage
- <export: true> "use export: not api, so it won't be written to cointerp.h. cogit.c is unaware of StackPage"
- <inline: false>
- <var: #thePage type: #'StackPage *'>
- self printFrameAndCallers: thePage headFP SP: thePage headSP short: true!
Item was added:
+ ----- Method: StackInterpreter>>shortPrintFramesInPage: (in category 'debug printing') -----
+ shortPrintFramesInPage: thePage
+ <export: true> "use export: not api, so it won't be written to cointerp.h. cogit.c is unaware of StackPage"
+ <inline: false>
+ <var: #thePage type: #'StackPage *'>
+ self printFrameAndCallers: thePage headFP SP: thePage headSP short: true!
Item was changed:
----- Method: StackInterpreter>>shortPrintOop: (in category 'debug printing') -----
shortPrintOop: oop
<inline: false>
self printHexnp: oop.
(objectMemory isImmediate: oop) ifTrue:
[(objectMemory isImmediateCharacter: oop) ifTrue:
[^self
cCode: 'printf("=$%ld ($%c)\n", (long)characterValueOf(oop), (long)characterValueOf(oop))'
inSmalltalk: [self print: (self shortPrint: oop); cr]].
^self
cCode: 'printf("=%ld\n", (long)integerValueOf(oop))'
inSmalltalk: [self print: (self shortPrint: oop); cr]].
(objectMemory addressCouldBeObj: oop) ifFalse:
[self print: ((oop bitAnd: objectMemory allocationUnit - 1) ~= 0
ifTrue: [' is misaligned']
ifFalse: [' is not on the heap']); cr.
^nil].
((objectMemory isFreeObject: oop)
or: [objectMemory isForwarded: oop]) ifTrue:
[^self printOop: oop].
self print: ': a(n) '.
self printNameOfClass: (objectMemory fetchClassOfNonImm: oop) count: 5.
self cr!
Item was changed:
----- Method: StackInterpreter>>shortUnconditionalJump (in category 'jump bytecodes') -----
shortUnconditionalJump
<expandCases>
self jump: (currentBytecode bitAnd: 7) + 1.!
Item was changed:
----- Method: StackInterpreter>>showDisplayBits:Left:Top:Right:Bottom: (in category 'I/O primitive support') -----
showDisplayBits: aForm Left: l Top: t Right: r Bottom: b
"Repaint the portion of the Smalltalk screen bounded by the affected rectangle. Used to synchronize the screen after a Bitblt to the Smalltalk Display object."
deferDisplayUpdates ifTrue: [^ nil].
self displayBitsOf: aForm Left: l Top: t Right: r Bottom: b!
Item was removed:
- ----- Method: StackInterpreter>>singleExtendedSendBytecode (in category 'send bytecodes') -----
- singleExtendedSendBytecode
- "Can use any of the first 32 literals for the selector and pass up to 7 arguments."
-
- | descriptor |
- descriptor := self fetchByte.
- messageSelector := self literal: (descriptor bitAnd: 16r1F).
- argumentCount := descriptor >> 5.
- self normalSend.!
Item was added:
+ ----- Method: StackInterpreter>>singleExtendedSendBytecode (in category 'send bytecodes') -----
+ singleExtendedSendBytecode
+ "Can use any of the first 32 literals for the selector and pass up to 7 arguments."
+
+ | descriptor |
+ descriptor := self fetchByte.
+ messageSelector := self literal: (descriptor bitAnd: 16r1F).
+ argumentCount := descriptor >> 5.
+ self normalSend.!
Item was removed:
- ----- Method: StackInterpreter>>singleExtendedSuperBytecode (in category 'send bytecodes') -----
- singleExtendedSuperBytecode
- "Can use any of the first 32 literals for the selector and pass up to 7 arguments."
-
- | descriptor |
- descriptor := self fetchByte.
- messageSelector := self literal: (descriptor bitAnd: 16r1F).
- argumentCount := descriptor >> 5.
- self superclassSend.
- !
Item was added:
+ ----- Method: StackInterpreter>>singleExtendedSuperBytecode (in category 'send bytecodes') -----
+ singleExtendedSuperBytecode
+ "Can use any of the first 32 literals for the selector and pass up to 7 arguments."
+
+ | descriptor |
+ descriptor := self fetchByte.
+ messageSelector := self literal: (descriptor bitAnd: 16r1F).
+ argumentCount := descriptor >> 5.
+ self superclassSend.
+ !
Item was changed:
----- Method: StackInterpreter>>sizeOfCallPrimitiveBytecode: (in category 'compiled methods') -----
sizeOfCallPrimitiveBytecode: methodHeader
"Answer if the method starts with a long store temp bytecode, which indicates it has a primitive error code."
"249 11111001 i i i i i i i i jjjjjjjj Call Primitive #iiiiiiii + (jjjjjjjj * 256)"
<api>
<inline: true>
^self
cppIf: MULTIPLEBYTECODESETS
ifTrue: [(self headerIndicatesAlternateBytecodeSet: methodHeader)
ifTrue: [3]
ifFalse: [0]]
ifFalse: [0]!
Item was removed:
- ----- 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) - BaseHeaderSize.
- (objectMemory isWordsOrBytes: oop) ifFalse: [
- self primitiveFail.
- ^0].
- ^objectMemory lengthOf: oop
- !
Item was added:
+ ----- 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) - BaseHeaderSize.
+ (objectMemory isWordsOrBytes: oop) ifFalse: [
+ self primitiveFail.
+ ^0].
+ ^objectMemory lengthOf: oop
+ !
Item was changed:
----- Method: StackInterpreter>>snapshot: (in category 'image save/restore') -----
snapshot: embedded
"update state of active context"
+ | activeContext activeProc rcvr setMacType stackIndex |
+ <var: #setMacType type: #'void *'>
- | activeContext activeProc dataSize rcvr setMacType stackIndex |
- <var: #setMacType type: 'void *'>
"For now the stack munging below doesn't deal with more than one argument.
It can, and should."
argumentCount ~= 0 ifTrue:
[^self primitiveFailFor: PrimErrBadNumArgs].
"Need to convert all frames into contexts since the snapshot file only holds objects."
self push: instructionPointer.
activeContext := self voidVMStateForSnapshot.
"update state of active process"
activeProc := self activeProcess.
objectMemory
storePointer: SuspendedContextIndex
ofObject: activeProc
withValue: activeContext.
objectMemory pushRemappableOop: activeContext.
"garbage collect, bereave contexts and flush external methods."
self snapshotCleanUp.
"Nothing moves from here on so it is safe to grab the activeContext again."
activeContext := objectMemory popRemappableOop.
- dataSize := objectMemory freeStart - objectMemory startOfMemory. "Assume all objects are below the start of the free block"
self successful ifTrue:
["Without contexts or stacks simulate
rcvr := self popStack. ''pop rcvr''
self push: trueObj.
to arrange that the snapshot resumes with true. N.B. stackIndex is one-relative."
stackIndex := self quickFetchInteger: StackPointerIndex ofObject: activeContext.
rcvr := objectMemory fetchPointer: stackIndex + CtxtTempFrameStart - 1 ofObject: activeContext.
objectMemory
storePointerUnchecked: stackIndex + CtxtTempFrameStart - 1
ofObject: activeContext
withValue: objectMemory trueObject.
"now attempt to write the snapshot file"
+ self writeImageFileIO.
- self writeImageFileIO: dataSize.
(self successful and: [embedded not]) ifTrue:
["set Mac file type and creator; this is a noop on other platforms"
setMacType := self ioLoadFunction: 'setMacFileTypeAndCreator' From: 'FilePlugin'.
setMacType = 0 ifFalse:
[self cCode: '((sqInt (*)(char *, char *, char *))setMacType)(imageName, "STim", "FAST")']].
"Without contexts or stacks simulate
self pop: 1"
objectMemory
storePointerUnchecked: StackPointerIndex
ofObject: activeContext
withValue: (objectMemory integerObjectOf: stackIndex - 1)].
self marryContextInNewStackPageAndInitializeInterpreterRegisters: activeContext.
self successful
ifTrue: [self push: objectMemory falseObject]
ifFalse:
[self push: rcvr.
self justActivateNewMethod]!
Item was changed:
----- Method: StackInterpreter>>snapshotCleanUp (in category 'image save/restore') -----
snapshotCleanUp
"Clean up right before saving an image, garbage collecting, sweeping memory and:
* nilling out all fields of contexts above the stack pointer.
* flushing external primitives
* clearing the root bit of any object in the root table
* bereaving widowed contexts.
By ensuring that all contexts are single in a snapshot (i.e. that no married contexts
exist) we can maintain the invariant that a married or widowed context's frame
reference (in its sender field) must point into the stack pages since no married or
widowed contexts are present from older runs of the system."
objectMemory hasSpurMemoryManagerAPI
ifTrue: [objectMemory flushNewSpace]
ifFalse: [objectMemory incrementalGC]. "compact memory and compute the size of the memory actually in use"
"maximimize space for forwarding table"
objectMemory fullGC.
objectMemory allObjectsDo:
[:obj| | header fmt sz |
header := self longAt: obj.
fmt := objectMemory formatOfHeader: header.
"Clean out context"
(fmt = objectMemory indexablePointersFormat
and: [objectMemory isContextHeader: header]) ifTrue:
["All contexts have been divorced. Bereave remaining widows."
(self isMarriedOrWidowedContext: obj) ifTrue:
[self markContextAsDead: obj].
"Fill slots beyond top of stack with nil"
+ (self fetchStackPointerOf: obj) + CtxtTempFrameStart
+ to: (objectMemory numSlotsOf: obj) - 1
+ do: [:i |
+ objectMemory
+ storePointerUnchecked: i
- (self fetchStackPointerOf: obj) to: (objectMemory numSlotsOf: obj) do:
- [:i | objectMemory
- storePointerUnchecked: i + CtxtTempFrameStart
ofObject: obj
withValue: objectMemory nilObject]].
"Clean out external functions from compiled methods"
fmt >= objectMemory firstCompiledMethodFormat ifTrue:
["Its primitiveExternalCall"
(self primitiveIndexOf: obj) = PrimitiveExternalCallIndex ifTrue:
[self flushExternalPrimitiveOf: obj]]].
objectMemory hasSpurMemoryManagerAPI ifFalse:
[objectMemory clearRootsTable]!
Item was changed:
----- Method: StackInterpreter>>space (in category 'debug printing') -----
space
<inline: true>
self printChar: $ !
Item was changed:
----- Method: StackInterpreter>>specialSelector: (in category 'message sending') -----
specialSelector: index
<api>
^objectMemory fetchPointer: (index * 2) ofObject: (objectMemory splObj: SpecialSelectors)!
Item was changed:
----- Method: StackInterpreter>>stObject:at: (in category 'indexing primitive support') -----
stObject: array at: index
"Return what ST would return for <obj> at: index."
| hdr fmt totalLength fixedFields stSize |
<inline: true>
hdr := objectMemory baseHeader: array.
fmt := objectMemory formatOfHeader: hdr.
totalLength := objectMemory lengthOf: array baseHeader: hdr format: fmt.
fixedFields := objectMemory fixedFieldsOf: array format: fmt length: totalLength.
(fmt = objectMemory indexablePointersFormat
and: [objectMemory isContextHeader: hdr])
ifTrue:
[stSize := self stackPointerForMaybeMarriedContext: array.
((self oop: index isGreaterThanOrEqualTo: 1)
and: [(self oop: index isLessThanOrEqualTo: stSize)
and: [self isStillMarriedContext: array]]) ifTrue:
[^self noInlineTemporary: index - 1 in: (self frameOfMarriedContext: array)]]
ifFalse: [stSize := totalLength - fixedFields].
((self oop: index isGreaterThanOrEqualTo: (objectMemory firstValidIndexOfIndexableObject: array withFormat: fmt))
and: [self oop: index isLessThanOrEqualTo: stSize]) ifTrue:
[^self subscript: array with: (index + fixedFields) format: fmt].
self primitiveFailFor: (fmt <= 1 ifTrue: [PrimErrBadReceiver] ifFalse: [PrimErrBadIndex]).
^0!
Item was changed:
----- Method: StackInterpreter>>stObject:at:put: (in category 'indexing primitive support') -----
stObject: array at: index put: value
"Do what ST would return for <obj> at: index put: value."
| hdr fmt totalLength fixedFields stSize |
<inline: true>
hdr := objectMemory baseHeader: array.
fmt := objectMemory formatOfHeader: hdr.
totalLength := objectMemory lengthOf: array baseHeader: hdr format: fmt.
fixedFields := objectMemory fixedFieldsOf: array format: fmt length: totalLength.
(fmt = objectMemory indexablePointersFormat
and: [objectMemory isContextHeader: hdr])
ifTrue:
[stSize := self stackPointerForMaybeMarriedContext: array.
((self oop: index isGreaterThanOrEqualTo: 1)
and: [(self oop: index isLessThanOrEqualTo: stSize)
and: [self isStillMarriedContext: array]]) ifTrue:
[^self noInlineTemporary: index - 1 in: (self frameOfMarriedContext: array) put: value]]
ifFalse: [stSize := totalLength - fixedFields].
((self oop: index isGreaterThanOrEqualTo: (objectMemory firstValidIndexOfIndexableObject: array withFormat: fmt))
and: [self oop: index isLessThanOrEqualTo: stSize])
ifTrue: [self subscript: array with: (index + fixedFields) storing: value format: fmt]
ifFalse: [self primitiveFailFor: (fmt <= 1 ifTrue: [PrimErrBadReceiver] ifFalse: [PrimErrBadIndex])].
^value!
Item was added:
+ ----- Method: StackInterpreter>>stackIntegerValue: (in category 'internal interpreter access') -----
+ stackIntegerValue: offset
+ "In the StackInterpreter stacks grow down."
+ | integerPointer |
+ integerPointer := stackPages longAt: stackPointer + (offset*BytesPerWord).
+ ^self checkedIntegerValueOf: integerPointer!
Item was removed:
- ----- Method: StackInterpreter>>stackIntegerValue: (in category 'internal interpreter access') -----
- stackIntegerValue: offset
- "In the StackInterpreter stacks grow down."
- | integerPointer |
- integerPointer := stackPages longAt: stackPointer + (offset*BytesPerWord).
- ^self checkedIntegerValueOf: integerPointer!
Item was changed:
----- Method: StackInterpreter>>stackObjectValue: (in category 'internal interpreter 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 * BytesPerWord).
(objectMemory isImmediate: oop) ifTrue:
[self primitiveFail. ^ nil].
^oop!
Item was removed:
- ----- Method: StackInterpreter>>stackPointerForMaybeMarriedContext: (in category 'internal interpreter access') -----
- stackPointerForMaybeMarriedContext: aContext
- "Return the stackPointer of a Context or BlockContext."
- | sp |
- <inline: true>
- (self isStillMarriedContext: aContext) ifTrue:
- [sp := self stackPointerIndexForFrame: (self frameOfMarriedContext: aContext).
- self assert: ReceiverIndex + (objectMemory integerValueOf: sp) < (objectMemory lengthOf: aContext).
- ^sp].
- ^self fetchStackPointerOf: aContext!
Item was added:
+ ----- Method: StackInterpreter>>stackPointerForMaybeMarriedContext: (in category 'internal interpreter access') -----
+ stackPointerForMaybeMarriedContext: aContext
+ "Return the stackPointer of a Context or BlockContext."
+ | sp |
+ <inline: true>
+ (self isStillMarriedContext: aContext) ifTrue:
+ [sp := self stackPointerIndexForFrame: (self frameOfMarriedContext: aContext).
+ self assert: ReceiverIndex + (objectMemory integerValueOf: sp) < (objectMemory lengthOf: aContext).
+ ^sp].
+ ^self fetchStackPointerOf: aContext!
Item was changed:
----- Method: StackInterpreter>>stackPointerIndex (in category 'internal interpreter access') -----
stackPointerIndex
"Return the 1-based value of the stack pointer for the current frame.
This is what the value of the stackp slot would be in a context object."
^self stackPointerIndexForFrame: framePointer WithSP: stackPointer!
Item was changed:
----- Method: StackInterpreter>>stackPointerIndexForFrame: (in category 'frame access') -----
stackPointerIndexForFrame: theFP
"Return the 0-based index rel to the given frame.
(This is what stackPointer used to be before conversion to pointer)"
"In the StackInterpreter stacks grow down."
| thePage theSP |
<inline: false>
<var: #theFP type: #'char *'>
<var: #thePage type: #'StackPage *'>
<var: #theSP type: #'char *'>
thePage := stackPages stackPageFor: theFP.
theSP := self findSPOf: theFP on: thePage.
^self stackPointerIndexForFrame: theFP WithSP: theSP!
Item was changed:
----- Method: StackInterpreter>>stackPositiveMachineIntegerValue: (in category 'internal interpreter access') -----
stackPositiveMachineIntegerValue: offset
<api>
"In the StackInterpreter stacks grow down."
| integerPointer |
integerPointer := stackPages longAt: stackPointer + (offset*BytesPerWord).
^self positiveMachineIntegerValueOf: integerPointer!
Item was changed:
----- Method: StackInterpreter>>stackSignedMachineIntegerValue: (in category 'internal interpreter access') -----
stackSignedMachineIntegerValue: offset
<api>
"In the StackInterpreter stacks grow down."
| integerPointer |
integerPointer := stackPages longAt: stackPointer + (offset*BytesPerWord).
^self signedMachineIntegerValueOf: integerPointer!
Item was changed:
----- Method: StackInterpreter>>stackTop (in category 'internal interpreter access') -----
stackTop
<api>
^stackPages longAt: stackPointer!
Item was changed:
----- Method: StackInterpreter>>stackValue: (in category 'internal interpreter access') -----
stackValue: offset
<api>
"In the StackInterpreter stacks grow down."
^stackPages longAt: stackPointer + (offset*BytesPerWord)!
Item was changed:
----- Method: StackInterpreter>>stackValue:put: (in category 'internal interpreter access') -----
stackValue: offset put: oop
"In the StackInterpreter stacks grow down."
^stackPages
longAt: stackPointer + (offset*BytesPerWord)
put: oop!
Item was changed:
----- Method: StackInterpreter>>startPCOfMethod: (in category 'compiled methods') -----
startPCOfMethod: aCompiledMethod
<api>
"Zero-relative version of CompiledMethod>>startpc."
^(self literalCountOf: aCompiledMethod) + LiteralStart * objectMemory bytesPerOop!
Item was changed:
----- Method: StackInterpreter>>storeAndPopReceiverVariableBytecode (in category 'stack bytecodes') -----
storeAndPopReceiverVariableBytecode
"Note: This code uses
storePointerUnchecked:ofObject:withValue: and does the
store check explicitely in order to help the translator
produce better code."
| rcvr top |
rcvr := self receiver.
top := self internalStackTop.
objectMemory storePointer: (currentBytecode bitAnd: 7) ofObject: rcvr withValue: top.
self fetchNextBytecode.
self internalPop: 1!
Item was changed:
----- Method: StackInterpreter>>storeAndPopRemoteTempLongBytecode (in category 'stack bytecodes') -----
storeAndPopRemoteTempLongBytecode
self storeRemoteTempLongBytecode.
self internalPop: 1!
Item was changed:
----- Method: StackInterpreter>>storeAndPopTemporaryVariableBytecode (in category 'stack bytecodes') -----
storeAndPopTemporaryVariableBytecode
<expandCases>
self
cCode: "this bytecode will be expanded so that refs to currentBytecode below will be constant"
[self fetchNextBytecode.
self temporary: (currentBytecode bitAnd: 7) in: localFP put: self internalStackTop.
self internalPop: 1]
inSmalltalk: "Interpreter version has fetchNextBytecode out of order"
[self temporary: (currentBytecode bitAnd: 7) in: localFP put: self internalStackTop.
self fetchNextBytecode.
self internalPop: 1]!
Item was changed:
----- Method: StackInterpreter>>storeMaybeContextReceiverVariable:withValue: (in category 'stack bytecodes') -----
storeMaybeContextReceiverVariable: fieldIndex withValue: anObject
"Must trap accesses to married and widowed contexts.
But don't want to check on all inst var accesses. This
method is only used by the long-form bytecodes, evading the cost."
| rcvr |
rcvr := self receiver.
((self isWriteMediatedContextInstVarIndex: fieldIndex)
and: [(objectMemory isContextNonImm: rcvr)
and: [self isMarriedOrWidowedContext: rcvr]])
ifTrue:
[self instVar: fieldIndex ofContext: rcvr put: anObject]
ifFalse:
[objectMemory storePointer: fieldIndex ofObject: rcvr withValue: anObject]
!
Item was changed:
----- Method: StackInterpreter>>storeRemoteTemp:inVectorAt: (in category 'stack bytecodes') -----
storeRemoteTemp: index inVectorAt: tempVectorIndex
| tempVector |
tempVector := self temporary: tempVectorIndex in: localFP.
objectMemory storePointer: index ofObject: tempVector withValue: self internalStackTop.!
Item was changed:
----- Method: StackInterpreter>>storeRemoteTempLongBytecode (in category 'stack bytecodes') -----
storeRemoteTempLongBytecode
| remoteTempIndex tempVectorIndex |
remoteTempIndex := self fetchByte.
tempVectorIndex := self fetchByte.
self fetchNextBytecode.
self storeRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex!
Item was changed:
----- Method: StackInterpreter>>storeStackPointerValue:inContext: (in category 'internal interpreter access') -----
storeStackPointerValue: value inContext: aContext
"Assume: value is an integerValue"
self assert: ReceiverIndex + value < (objectMemory lengthOf: aContext).
objectMemory storePointerUnchecked: StackPointerIndex
ofObject: aContext
withValue: (objectMemory integerObjectOf: value)!
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>>superclassOf: (in category 'message sending') -----
superclassOf: classPointer
<inline: true>
^objectMemory fetchPointer: SuperclassIndex ofObject: classPointer!
Item was changed:
----- Method: StackInterpreter>>tab (in category 'debug printing') -----
tab
<inline: true>
self printChar: $ "<-Character tab"!
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) * BytesPerWord) put: valueOop]
ifFalse: [stackPages longAt: theFP + FoxReceiver - BytesPerWord + ((frameNumArgs - offset) * BytesPerWord) put: valueOop]!
Item was changed:
----- Method: StackInterpreter>>temporaryCountOfMethodHeader: (in category 'compiled methods') -----
temporaryCountOfMethodHeader: header
<api>
<inline: true>
^(header >> 19) bitAnd: 16r3F!
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) * BytesPerWord)]
ifFalse: [theFP + FoxReceiver - BytesPerWord + ((numArgs - offset) * BytesPerWord)]!
Item was changed:
----- Method: StackInterpreter>>unPop: (in category 'internal interpreter access') -----
unPop: nItems
"In the StackInterpreter stacks grow down."
stackPointer := stackPointer - (nItems*BytesPerWord)!
Item was added:
+ ----- Method: StackInterpreter>>undoFetchNextBytecode (in category 'interpreter shell') -----
+ undoFetchNextBytecode
+ "Backup the ip when it has been incremented to fetch the next bytecode."
+
+ localIP := localIP - 1!
Item was removed:
- ----- Method: StackInterpreter>>undoFetchNextBytecode (in category 'interpreter shell') -----
- undoFetchNextBytecode
- "Backup the ip when it has been incremented to fetch the next bytecode."
-
- localIP := localIP - 1!
Item was changed:
----- Method: StackInterpreter>>unknownShortOrCodeSizeInKs (in category 'image save/restore') -----
unknownShortOrCodeSizeInKs
"preserve whatever this value was (for images run on Cog)"
^theUnknownShort!
Item was removed:
- ----- 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 *'>
- <var: #argsPointer 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 - 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 - 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 - BytesPerWord].
- self assert: ReceiverIndex + tempIndex < (objectMemory lengthOf: theContext).
- objectMemory storePointerUnchecked: StackPointerIndex
- ofObject: theContext
- withValue: (objectMemory integerObjectOf: tempIndex)!
Item was added:
+ ----- 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 *'>
+ <var: #argsPointer 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 - 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 - 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 - BytesPerWord].
+ self assert: ReceiverIndex + tempIndex < (objectMemory lengthOf: theContext).
+ objectMemory storePointerUnchecked: StackPointerIndex
+ ofObject: theContext
+ withValue: (objectMemory integerObjectOf: tempIndex)!
Item was changed:
----- Method: StackInterpreter>>validInstructionPointer:inFrame: (in category 'debug support') -----
validInstructionPointer: anInstrPointer inFrame: fp
<var: #anInstrPointer type: #usqInt>
<var: #fp type: #'char *'>
<inline: false>
^self validInstructionPointer: anInstrPointer inMethod: (self frameMethodObject: fp) framePointer: fp!
Item was changed:
----- Method: StackInterpreter>>validInstructionPointer:inMethod:framePointer: (in category 'debug support') -----
validInstructionPointer: theInstrPointer inMethod: aMethod framePointer: fp
<var: #theInstrPointer type: #usqInt>
<var: #aMethod type: #usqInt>
<var: #fp type: #'char *'>
^self
cppIf: MULTIPLEBYTECODESETS
ifTrue:
[| methodHeader |
methodHeader := self noAssertHeaderOf: aMethod. "-1 for pre-increment in fetchNextBytecode"
theInstrPointer >= (aMethod + (objectMemory lastPointerOf: aMethod) + BaseHeaderSize - 1)
and: [theInstrPointer < (aMethod + (objectMemory byteLengthOf: aMethod) + BaseHeaderSize - 1)
and: ["If the method starts with a CallPrimitive opcode the instruction pointer should be past it."
((self headerIndicatesAlternateBytecodeSet: methodHeader)
and: [(self alternateHeaderHasPrimitiveFlag: methodHeader)
and: [theInstrPointer < (aMethod
+ BaseHeaderSize - 1
+ (objectMemory lastPointerOf: aMethod)
+ (self sizeOfCallPrimitiveBytecode: methodHeader) - 1)]])
not]]]
ifFalse: "-1 for pre-increment in fetchNextBytecode"
[theInstrPointer >= (aMethod + (objectMemory lastPointerOf: aMethod))
and: [theInstrPointer < (aMethod + (objectMemory byteLengthOf: aMethod) + objectMemory baseHeaderSize - 1)]]!
Item was changed:
----- Method: StackInterpreter>>voidVMStateForSnapshot (in category 'frame access') -----
voidVMStateForSnapshot
"Make sure that all VM state that affects the heap contents is voided so that the heap is ready
to be snapshotted. Answer the activeContext object that should be stored in the snapshot."
| activeContext |
<inline: false>
activeContext := self divorceAllFrames.
self bereaveAllMarriedContexts.
^activeContext!
Item was changed:
----- Method: StackInterpreter>>withoutSmallIntegerTags: (in category 'frame access') -----
withoutSmallIntegerTags: anInteger
<inline: true>
<returnTypeC: #'char *'>
self assert: (objectMemory isIntegerObject: anInteger).
^self pointerForOop: (anInteger - 1)!
Item was removed:
- ----- Method: StackInterpreter>>wordSwapped: (in category 'image save/restore') -----
- wordSwapped: w
- "Return the given 64-bit integer with its halves in the reverse order."
-
- BytesPerWord = 8 ifFalse: [self error: 'This cannot happen.'].
- ^ ((w bitShift: Byte4ShiftNegated) bitAnd: Bytes3to0Mask)
- + ((w bitShift: Byte4Shift ) bitAnd: Bytes7to4Mask)
- !
Item was added:
+ ----- Method: StackInterpreter>>wordSwapped: (in category 'image save/restore') -----
+ wordSwapped: w
+ "Return the given 64-bit integer with its halves in the reverse order."
+
+ BytesPerWord = 8 ifFalse: [self error: 'This cannot happen.'].
+ ^ ((w bitShift: Byte4ShiftNegated) bitAnd: Bytes3to0Mask)
+ + ((w bitShift: Byte4Shift ) bitAnd: Bytes7to4Mask)
+ !
Item was added:
+ ----- Method: StackInterpreter>>writeImageFileIO (in category 'image save/restore') -----
+ writeImageFileIO
+
+ | headerStart headerSize f bytesWritten sCWIfn okToWrite |
+ <var: #f type: 'sqImageFile'>
+ <var: #headerStart type: 'squeakFileOffsetType '>
+ <var: #sCWIfn type: 'void *'>
+
+ "If the security plugin can be loaded, use it to check for write permission.
+ If not, assume it's ok"
+ sCWIfn := self ioLoadFunction: 'secCanWriteImage' From: 'SecurityPlugin'.
+ sCWIfn ~= 0 ifTrue:
+ [okToWrite := self cCode: '((sqInt (*)(void))sCWIfn)()'.
+ okToWrite ifFalse:[^self primitiveFail]].
+
+ "local constants"
+ headerStart := 0.
+ headerSize := 64. "header size in bytes; do not change!!"
+
+ f := self cCode: 'sqImageFileOpen(imageName, "wb")'.
+ f = nil ifTrue: "could not open the image file for writing"
+ [^self primitiveFail].
+
+ headerStart := self cCode: 'sqImageFileStartLocation(f,imageName,headerSize+imageBytes)'.
+ self cCode: '/* Note: on Unix systems one could put an exec command here, padded to 512 bytes */'.
+ "position file to start of header"
+ self sqImageFile: f Seek: headerStart.
+
+ self putLong: self imageFormatVersion toFile: f.
+ self putLong: headerSize toFile: f.
+ self putLong: objectMemory imageSizeToWrite toFile: f.
+ self putLong: objectMemory baseAddressOfImage toFile: f.
+ self putLong: objectMemory specialObjectsOop toFile: f.
+ self putLong: objectMemory newObjectHash toFile: f.
+ self putLong: self ioScreenSize toFile: f.
+ self putLong: self getImageHeaderFlags toFile: f.
+ self putLong: extraVMMemory toFile: f.
+ self putShort: desiredNumStackPages toFile: f.
+ self putShort: self unknownShortOrCodeSizeInKs toFile: f.
+ self putLong: desiredEdenBytes toFile: f.
+ self putShort: (maxExtSemTabSizeSet ifTrue: [self ioGetMaxExtSemTableSize] ifFalse: [0]) toFile: f.
+ self putShort: 0 toFile: f.
+ objectMemory hasSpurMemoryManagerAPI
+ ifTrue:
+ [self putLong: objectMemory firstSegmentBytes toFile: f."Pad the rest of the header."
+ 3 timesRepeat: [self putLong: 0 toFile: f]]
+ ifFalse:
+ [1 to: 4 do: [:i | self putLong: 0 toFile: f]]. "fill remaining header words with zeros"
+ self successful ifFalse: [
+ "file write or seek failure"
+ self cCode: 'sqImageFileClose(f)'.
+ ^ nil].
+
+ "position file after the header"
+ self sqImageFile: f Seek: headerStart + headerSize.
+
+ "write the image data"
+ objectMemory hasSpurMemoryManagerAPI
+ ifTrue:
+ [bytesWritten := objectMemory segmentManager writeImageToFile: f]
+ ifFalse:
+ [| memStart |
+ memStart := objectMemory baseAddressOfImage.
+ bytesWritten := self cCode: 'sqImageFileWrite(pointerForOop(memStart), sizeof(unsigned char), imageBytes, f)'.
+ self touch: memStart].
+ self success: bytesWritten = objectMemory imageSizeToWrite.
+ self cCode: 'sqImageFileClose(f)'
+ !
Item was removed:
- ----- Method: StackInterpreter>>writeImageFileIO: (in category 'image save/restore') -----
- writeImageFileIO: imageBytes
-
- | headerStart headerSize f bytesWritten sCWIfn okToWrite memStart |
- <var: #f type: 'sqImageFile'>
- <var: #headerStart type: 'squeakFileOffsetType '>
- <var: #sCWIfn type: 'void *'>
-
- "If the security plugin can be loaded, use it to check for write permission.
- If not, assume it's ok"
- sCWIfn := self ioLoadFunction: 'secCanWriteImage' From: 'SecurityPlugin'.
- sCWIfn ~= 0 ifTrue:
- [okToWrite := self cCode: '((sqInt (*)(void))sCWIfn)()'.
- okToWrite ifFalse:[^self primitiveFail]].
-
- "local constants"
- headerStart := 0.
- headerSize := 64. "header size in bytes; do not change!!"
-
- f := self cCode: 'sqImageFileOpen(imageName, "wb")'.
- f = nil ifTrue: "could not open the image file for writing"
- [^self primitiveFail].
-
- headerStart := self cCode: 'sqImageFileStartLocation(f,imageName,headerSize+imageBytes)'.
- self cCode: '/* Note: on Unix systems one could put an exec command here, padded to 512 bytes */'.
- "position file to start of header"
- self sqImageFile: f Seek: headerStart.
-
- self putLong: self imageFormatVersion toFile: f.
- self putLong: headerSize toFile: f.
- self putLong: imageBytes toFile: f.
- self putLong: objectMemory startOfMemory toFile: f.
- self putLong: objectMemory specialObjectsOop toFile: f.
- self putLong: objectMemory newObjectHash toFile: f.
- self putLong: self ioScreenSize toFile: f.
- self putLong: self getImageHeaderFlags toFile: f.
- self putLong: extraVMMemory toFile: f.
- self putShort: desiredNumStackPages toFile: f.
- self putShort: self unknownShortOrCodeSizeInKs toFile: f.
- self putLong: desiredEdenBytes toFile: f.
- self putShort: (maxExtSemTabSizeSet ifTrue: [self ioGetMaxExtSemTableSize] ifFalse: [0]) toFile: f.
- self putShort: 0 toFile: f.
- 1 to: 4 do: [:i | self putLong: 0 toFile: f]. "fill remaining header words with zeros"
- self successful ifFalse: [
- "file write or seek failure"
- self cCode: 'sqImageFileClose(f)'.
- ^ nil].
-
- "position file after the header"
- self sqImageFile: f Seek: headerStart + headerSize.
-
- "write the image data"
- memStart := objectMemory startOfMemory.
- bytesWritten := self cCode: 'sqImageFileWrite(pointerForOop(memStart), sizeof(unsigned char), imageBytes, f)'.
- self success: bytesWritten = imageBytes.
- self touch: memStart.
- self cCode: 'sqImageFileClose(f)'
- !
Item was added:
+ ----- Method: StackInterpreterSimulator>>dispatchMappedPluginEntry: (in category 'plugin primitive support') -----
+ dispatchMappedPluginEntry: n
+ ^(mappedPluginEntries at: n) first
+ perform: (mappedPluginEntries at: n) second!
Item was added:
+ ----- Method: StackInterpreterSimulator>>imageNameGet:Length: (in category 'file primitives') -----
+ imageNameGet: p Length: sz
+ 1 to: sz do:
+ [:i |
+ objectMemory
+ byteAt: p + i - 1
+ put: (imageName at: i) asInteger]!
Item was added:
+ ----- Method: StackInterpreterSimulator>>imageNamePut:Length: (in category 'file primitives') -----
+ imageNamePut: p Length: sz
+ | newName |
+ newName := ByteString new: sz.
+ 1 to: sz do:
+ [:i |
+ newName
+ at: i
+ put: (Character value: (objectMemory byteAt: p + i - 1))].
+ imageName := newName!
Item was added:
+ ----- Method: StackInterpreterSimulator>>imageNameSize (in category 'file primitives') -----
+ imageNameSize
+ ^imageName size!
Item was removed:
- ----- Method: StackInterpreterSimulator>>primitiveImageName (in category 'file primitives') -----
- primitiveImageName
- "Note: For now, this only implements getting, not setting, the image file name."
- | result imageNameSize |
- self pop: 1.
- imageNameSize := imageName size.
- result := objectMemory instantiateClass: (objectMemory splObj: ClassByteString)
- indexableSize: imageNameSize.
- 1 to: imageNameSize do:
- [:i | objectMemory storeByte: i-1 ofObject: result
- withValue: (imageName at: i) asciiValue].
- self push: result.!
Item was added:
+ ----- Method: StackInterpreterSimulator>>writeImageFileIO (in category 'image save/restore') -----
+ writeImageFileIO
+ "Write the image to a file as an image snapshot."
+
+ | headerSize file |
+ BytesPerWord = 4 ifFalse: [self error: 'Not rewritten for 64 bits yet'].
+ headerSize := 64.
+
+ (file := FileStream fileNamed: imageName) ifNil:
+ [self primitiveFail.
+ ^nil].
+ [
+ file binary.
+
+ {
+ self imageFormatVersion.
+ headerSize.
+ objectMemory imageSizeToWrite.
+ objectMemory baseAddressOfImage.
+ objectMemory specialObjectsOop.
+ objectMemory lastHash.
+ self ioScreenSize.
+ self getImageHeaderFlags.
+ extraVMMemory
+ }
+ do: [:long | self putLong: long toFile: file].
+
+ { desiredNumStackPages. self unknownShortOrCodeSizeInKs } do:
+ [:short| self putShort: short toFile: file].
+
+ self putLong: desiredEdenBytes toFile: file.
+
+ { maxExtSemTabSizeSet ifTrue: [self ioGetMaxExtSemTableSize] ifFalse: [0]. 0 } do:
+ [:short| self putShort: short toFile: file].
+
+ objectMemory hasSpurMemoryManagerAPI
+ ifTrue:
+ [| bytesWritten |
+ self putLong: objectMemory firstSegmentBytes toFile: file."Pad the rest of the header."
+ 3 timesRepeat: [self putLong: 0 toFile: file].
+
+ "Position the file after the header."
+ file position: headerSize.
+ bytesWritten := objectMemory segmentManager writeImageToFile: 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 removed:
- ----- Method: StackInterpreterSimulator>>writeImageFileIO: (in category 'image save/restore') -----
- writeImageFileIO: numberOfBytesToWrite
- "Actually emit the first numberOfBytesToWrite object memory bytes onto the snapshot."
-
- | headerSize file |
- BytesPerWord = 4 ifFalse: [self error: 'Not rewritten for 64 bits yet'].
- headerSize := 64.
-
- [
- file := FileStream fileNamed: imageName.
- file == nil ifTrue:
- [self primitiveFail.
- ^nil].
- file binary.
-
- {
- self imageFormatVersion.
- headerSize.
- numberOfBytesToWrite.
- objectMemory startOfMemory.
- (objectMemory specialObjectsOop).
- (objectMemory lastHash).
- self ioScreenSize.
- self getImageHeaderFlags.
- extraVMMemory
- }
- do: [:long | self putLong: long toFile: file].
-
- { desiredNumStackPages. self unknownShortOrCodeSizeInKs } do:
- [:short| self putShort: short toFile: file].
-
- self putLong: desiredEdenBytes toFile: file.
-
- { maxExtSemTabSizeSet ifTrue: [self ioGetMaxExtSemTableSize] ifFalse: [0]. 0 } do:
- [:short| self putShort: short toFile: file].
-
- "Pad the rest of the header."
- 4 timesRepeat: [self putLong: 0 toFile: file].
-
- "Position the file after the header."
- file position: headerSize.
-
- "Write the object memory."
- objectMemory startOfMemory // 4 + 1
- to: numberOfBytesToWrite // 4
- do: [:index |
- self
- putLong: (objectMemory memory at: index)
- toFile: file].
-
- self success: true
- ]
- ensure: [file ifNotNil: [file close]]!
1
0
Eliot Miranda uploaded a new version of Cog to project VM Maker:
http://source.squeak.org/VMMaker/Cog-eem.108.mcz
==================== Summary ====================
Name: Cog-eem.108
Author: eem
Time: 9 October 2013, 9:13:47.265 am
UUID: 5987309e-f957-42d5-856f-a599ebb32f0e
Ancestors: Cog-eem.107, Cog-eem.104
Reattach history lost in the 105 commit.
=============== Diff against Cog-eem.107 ===============
Item was changed:
----- Method: SpurBootstrap>>writeSnapshotOfTransformedImage (in category 'testing') -----
writeSnapshotOfTransformedImage
"The bootstrapped image typically contains a few big free chunks and one huge free chunk.
Test snapshot writing and loading by turning the largest non-huge chunks into segment bridges
and saving."
| heap sizes counts barriers sim |
heap := TransformedImage veryDeepCopy.
sim := StackInterpreterSimulator onObjectMemory: heap.
heap coInterpreter: sim.
sim initializeInterpreter: 0.
sizes := Bag new.
heap allObjectsInFreeTree: (heap freeLists at: 0) do:
[:f|
sizes add: (heap bytesInObject: f)].
counts := sizes sortedCounts.
self assert: counts last key = 1. "1 huge chunk"
self assert: ((counts at: counts size - 1) key > 2
and: [(counts at: counts size - 1) value > 1024]).
barriers := (1 to: (counts at: counts size - 1) key) collect:
[:ign| heap allocateOldSpaceChunkOfExactlyBytes: (counts at: counts size - 1) value].
heap segmentManager initializeFromFreeChunks: (barriers sort collect: [:b| heap objectStartingAt: b]).
sim imageName: 'spur.image'.
+ sim writeImageFileIO!
- sim writeImageFileIO: heap !
1
0
Eliot Miranda uploaded a new version of VMMaker to project VM Maker:
http://source.squeak.org/VMMaker/VMMaker.oscog-eem.443.mcz
==================== Summary ====================
Name: VMMaker.oscog-eem.443
Author: eem
Time: 8 October 2013, 4:58:09.228 pm
UUID: 4e2052f0-eb89-438c-a109-ed213ba6d592
Ancestors: VMMaker.oscog-eem.442
Fix terrible slip in remapRemapBufferAndExtraRoots which causes
remapBuffer contents not to be remapped.
=============== Diff against VMMaker.oscog-eem.442 ===============
Item was changed:
----- Method: ObjectMemory>>remapRemapBufferAndExtraRoots (in category 'gc -- compaction') -----
remapRemapBufferAndExtraRoots
| oop |
1 to: remapBufferCount do:
[:i |
oop := remapBuffer at: i.
+ (self shouldRemapOop: oop) ifTrue:
- (self shouldRemapOop: oop) ifFalse:
[remapBuffer at: i put: (self remapObj: oop)]].
1 to: extraRootCount do:
[:i |
oop := (extraRoots at: i) at: 0.
((self isIntegerObject: oop) or: [self isFreeObject: oop]) ifFalse:
[(self shouldRemapObj: oop) ifTrue:
[(extraRoots at: i) at: 0 put: (self remapObj: oop)]]]!
1
0
Eliot Miranda uploaded a new version of VMMaker to project VM Maker:
http://source.squeak.org/VMMaker/VMMaker.oscog-eem.442.mcz
==================== Summary ====================
Name: VMMaker.oscog-eem.442
Author: eem
Time: 8 October 2013, 3:20:59.392 pm
UUID: e65a62ab-94da-4d61-934d-e60a36da3791
Ancestors: VMMaker.oscog-eem.441
More uses of allObjectsDo: in place of presumptious open-coded loop.
=============== Diff against VMMaker.oscog-eem.441 ===============
Item was changed:
----- Method: CoInterpreter>>ensureAllContextsHaveBytecodePCsOrAreBereaved (in category 'frame access') -----
ensureAllContextsHaveBytecodePCsOrAreBereaved
"Enumerate all contexts preparing them for a snapshot. Map all native pcs to bytecoded pcs.
Convert widowed contexts to single contexts so that the snapshot contains only single contexts.
This allows the being married test to avoid checking for a context's frame pointer being in bounds
since all frame pointers must have been created in the current system and so be in bounds.
Thanks to Greg Nuyens for this idea."
+ objectMemory allObjectsDo:
+ [:oop|
+ (objectMemory isContextNonImm: oop) ifTrue:
- | oop decodedIP |
- oop := objectMemory firstObject.
- [oop < objectMemory freeStart] whileTrue:
- [((objectMemory isFreeObject: oop) not
- and: [objectMemory isContextNonImm: oop]) ifTrue:
[(self isMarriedOrWidowedContext: oop)
ifTrue: "The stack pages have already been discarded. Any remaining married contexts are actually widows."
[self markContextAsDead: oop]
ifFalse:
+ [| decodedIP |
+ decodedIP := objectMemory fetchPointer: InstructionPointerIndex ofObject: oop.
- [decodedIP := objectMemory fetchPointer: InstructionPointerIndex ofObject: oop.
((objectMemory isIntegerObject: decodedIP)
and: [decodedIP signedIntFromLong < 0]) ifTrue:
[decodedIP := self mustMapMachineCodePC: (objectMemory integerValueOf: decodedIP)
context: oop.
+ objectMemory storePointerUnchecked: InstructionPointerIndex ofObject: oop withValue: decodedIP]]]]!
- objectMemory storePointerUnchecked: InstructionPointerIndex ofObject: oop withValue: decodedIP]]].
- oop := objectMemory objectAfter: oop]!
Item was changed:
----- Method: CoInterpreter>>ensureAllContextsWithMethodHaveBytecodePCs: (in category 'frame access') -----
ensureAllContextsWithMethodHaveBytecodePCs: methodObj
"Map all native pcs to bytecoded pcs in all contexts on methodObj.
Used to implement primitiveVoidVMStateForMethod."
+ objectMemory allObjectsDo:
+ [:oop|
+ ((objectMemory isContextNonImm: oop)
+ and: [(objectMemory fetchPointer: MethodIndex ofObject: oop) = methodObj]) ifTrue:
- | oop |
- oop := objectMemory firstObject.
- [oop < objectMemory freeStart] whileTrue:
- [((objectMemory isFreeObject: oop) not
- and: [(objectMemory isContextNonImm: oop)
- and: [(objectMemory fetchPointer: MethodIndex ofObject: oop) = methodObj]]) ifTrue:
[(self isMarriedOrWidowedContext: oop)
ifTrue:
[(self checkIsStillMarriedContext: oop currentFP: stackPage headFP) ifTrue:
[self assert: (self isMachineCodeFrame: (self frameOfMarriedContext: oop)) not]]
ifFalse:
+ [self ensureContextHasBytecodePC: oop]]]!
- [self ensureContextHasBytecodePC: oop]].
- oop := objectMemory objectAfter: oop]!
Item was changed:
----- Method: CogVMSimulator>>allObjectsSelect: (in category 'debug support') -----
allObjectsSelect: objBlock
"self allObjectsSelect: [:oop | (self baseHeader: oop) = 1234]"
+ | selected |
- | oop selected |
- oop := objectMemory firstObject.
selected := OrderedCollection new.
+ objectMemory allObjectsDo:
+ [:oop| (objBlock value: oop) ifTrue: [selected addLast: oop]].
- [oop < objectMemory endOfMemory] whileTrue:
- [(objectMemory isFreeObject: oop)
- ifFalse: [(objBlock value: oop) ifTrue: [selected addLast: oop]].
- oop := objectMemory objectAfter: oop].
^ selected!
Item was changed:
----- Method: CogVMSimulator>>objectBefore: (in category 'testing') -----
objectBefore: addr
+ | prev |
+ objectMemory allObjectsDo:
+ [:oop|
+ "look here if debugging prev obj overlapping this one"
+ oop >= addr ifTrue: [^prev].
+ prev := oop].
- | oop prev |
- oop := objectMemory firstObject.
- [oop < objectMemory endOfMemory] whileTrue:
- [prev := oop. "look here if debugging prev obj overlapping this one"
- oop := objectMemory objectAfter: oop.
- oop >= addr ifTrue: [^ prev]].
^0!
Item was changed:
----- Method: StackInterpreter>>printAllStacks (in category 'debug printing') -----
printAllStacks
"Print all the stacks of all running processes, including those that are currently suspended."
<api>
+ | classObj proc semaphoreClass mutexClass schedLists p processList |
- | oop classObj proc semaphoreClass mutexClass schedLists p processList |
<inline: false>
proc := self activeProcess.
self printNameOfClass: (objectMemory fetchClassOf: proc) count: 5; space; printHex: proc.
self print: ' priority '; printNum: (self quickFetchInteger: PriorityIndex ofObject: proc); cr.
self printCallStackFP: framePointer. "first the current activation"
semaphoreClass := objectMemory classSemaphore.
mutexClass := objectMemory classMutex.
+ objectMemory allObjectsDo:
+ [:oop|
+ classObj := objectMemory fetchClassOfNonImm: oop.
- oop := objectMemory firstObject.
- [self oop: oop isLessThan: objectMemory freeStart] whileTrue:
- [classObj := objectMemory fetchClassOfNonImm: oop.
(classObj = semaphoreClass
or: [classObj = mutexClass]) ifTrue:
+ [self printProcsOnList: oop]].
- [self printProcsOnList: oop].
- oop := objectMemory objectAfter: oop].
schedLists := objectMemory fetchPointer: ProcessListsIndex ofObject: self schedulerPointer.
p := highestRunnableProcessPriority = 0
ifTrue: [objectMemory fetchWordLengthOf: schedLists]
ifFalse: [highestRunnableProcessPriority].
p - 1 to: 0 by: -1 do:
[:pri|
processList := objectMemory fetchPointer: pri ofObject: schedLists.
(self isEmptyList: processList) ifFalse:
[self cr; print: 'processes at priority '; printNum: pri + 1.
self printProcsOnList: processList]]!
Item was changed:
----- Method: StackInterpreter>>reverseBytesInImage (in category 'image save/restore') -----
reverseBytesInImage
"Byte-swap all words in memory after reading in the entire image file with bulk read. Contributed by Tim Rowledge."
"First, byte-swap every word in the image. This fixes objects headers."
objectMemory reverseBytesFrom: objectMemory startOfMemory to: objectMemory freeStart.
+ "Second, return the bytes of bytes-type objects to their
+ orginal order, and perform any other format conversions."
+ self updateObjectsPostByteSwap!
- "Second, return the bytes of bytes-type objects to their orginal order, and perform any
- other format conversions."
- self updateObjectsPostByteSwapFrom: objectMemory firstObject to: objectMemory freeStart!
Item was added:
+ ----- 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 + BaseHeaderSize.
+ fmt >= self firstCompiledMethodFormat ifTrue: "compiled method; start after methodHeader and literals"
+ [methodHeader := self longAt: oop + BaseHeaderSize.
+ wordAddr := wordAddr + (((self literalCountOfHeader: methodHeader) + LiteralStart) * BytesPerWord)].
+ 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 + BaseHeaderSize.
+ self longAt: oop + BaseHeaderSize put: (self longAt: oop + BaseHeaderSize + 4).
+ self longAt: oop + BaseHeaderSize + 4 put: temp]
+ ifFalse:
+ [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 removed:
- ----- Method: StackInterpreter>>updateObjectsPostByteSwapFrom:to: (in category 'image save/restore') -----
- updateObjectsPostByteSwapFrom: startOop to: stopAddr
- "Byte-swap the words of all bytes objects in a range of the
- image, including Strings, ByteArrays, and CompiledMethods.
- This returns these objects to their original byte ordering
- after blindly byte-swapping the entire image. For compiled
- methods, byte-swap only their bytecodes part.
- Ensure floats are in platform-order."
- | oop fmt wordAddr methodHeader swapFloatWords temp |
- swapFloatWords := objectMemory vmEndianness ~= imageFloatsBigEndian.
- self assert: ClassFloatCompactIndex ~= 0.
- oop := startOop.
- [self oop: oop isLessThan: stopAddr] whileTrue:
- [(objectMemory isFreeObject: oop) ifFalse:
- [fmt := objectMemory formatOf: oop.
- fmt >= self firstByteFormat ifTrue: "oop contains bytes"
- [wordAddr := oop + BaseHeaderSize.
- fmt >= self firstCompiledMethodFormat ifTrue: "compiled method; start after methodHeader and literals"
- [methodHeader := self longAt: oop + BaseHeaderSize.
- wordAddr := wordAddr + BytesPerWord + ((methodHeader >> 10 bitAnd: 255) * BytesPerWord)].
- 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 + BaseHeaderSize.
- self longAt: oop + BaseHeaderSize put: (self longAt: oop + BaseHeaderSize + 4).
- self longAt: oop + BaseHeaderSize + 4 put: temp]
- ifFalse:
- [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)]]]].
- oop := objectMemory objectAfter: oop]!
Item was changed:
----- Method: StackInterpreterSimulator>>objectBefore: (in category 'testing') -----
objectBefore: addr
+ | prev |
+ objectMemory allObjectsDo:
+ [:oop|
+ "look here if debugging prev obj overlapping this one"
+ oop >= addr ifTrue: [^prev].
+ prev := oop].
- | oop prev |
- oop := objectMemory firstObject.
- [oop < objectMemory endOfMemory] whileTrue:
- [prev := oop. "look here if debugging prev obj overlapping this one"
- oop := objectMemory objectAfter: oop.
- oop >= addr ifTrue: [^ prev]].
^0!
1
0
Eliot Miranda uploaded a new version of VMMaker to project VM Maker:
http://source.squeak.org/VMMaker/VMMaker.oscog-eem.441.mcz
==================== Summary ====================
Name: VMMaker.oscog-eem.441
Author: eem
Time: 8 October 2013, 3:01:35.105 pm
UUID: 3ace9016-94ec-4db2-85a0-ef1e4589f5d2
Ancestors: VMMaker.oscog-eem.440
Initialize a SpurMemoryManager's SpurSegmentManager.
Initialize the end-of-segment zero-sized bridge.
Provide covenient initializers for segment bridge headers.
Add wordSizeClassPun & wordIndexableFormat abstractions for
free lists & bridges that vary from 32- to 64-bit.
Fix bug in, and simplify allocateOldSpaceChunkOfExactlyBytes:.
get the terminology right; sionara isSegmentSpanningFakeObjectPun ;-)
Rename convertFloatsToPlatformOrderFrom:to: to
convertFloatsToPlatformOrder (args unused).
Recategorize the puns.
=============== Diff against VMMaker.oscog-eem.440 ===============
Item was added:
+ ----- Method: Spur32BitMMLESimulator>>freeLists (in category 'spur bootstrap') -----
+ freeLists
+ ^freeLists!
Item was added:
+ ----- Method: Spur32BitMemoryManager>>initSegmentBridgeWithBytes:at: (in category 'segments') -----
+ initSegmentBridgeWithBytes: numBytes at: address
+ <var: #numBytes type: #usqLong>
+ | numSlots |
+ "must have room for a double header"
+ self assert: (numBytes \\ self allocationUnit = 0
+ and: [numBytes >= (self baseHeaderSize + self baseHeaderSize)]).
+ self flag: #endianness.
+ 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: (1 << self pinnedBitShift)
+ + (self wordIndexableFormat << self formatShift)
+ + self segmentBridgePun;
+ longAt: address + 12 put: self numSlotsMask << self numSlotsHalfShift!
Item was added:
+ ----- Method: Spur32BitMemoryManager>>wordIndexableFormat (in category 'header formats') -----
+ wordIndexableFormat
+ ^self firstLongFormat!
Item was added:
+ ----- Method: Spur32BitMemoryManager>>wordSizeClassIndexPun (in category 'class table') -----
+ wordSizeClassIndexPun
+ ^self thirtyTwoBitLongsClassIndexPun!
Item was added:
+ ----- Method: Spur64BitMemoryManager>>initSegmentBridgeWithBytes:at: (in category 'segments') -----
+ initSegmentBridgeWithBytes: numBytes at: address
+ | numSlots |
+ <var: #numBytes type: #usqLong>
+ self assert: (numBytes >= (self baseHeaderSize + self baseHeaderSize)
+ and: [numBytes \\ self allocationUnit = 0]).
+ numSlots := numBytes - self baseHeaderSize - self baseHeaderSize >> self shiftForWord.
+ self longAt: address
+ put: self numSlotsMask << self numSlotsFullShift + numSlots;
+ longAt: address + self baseHeaderSize
+ put: (self numSlotsMask << self numSlotsFullShift)
+ + (1 << self pinnedBitShift)
+ + (self wordIndexableFormat << self formatShift)
+ + self segmentBridgePun!
Item was added:
+ ----- Method: Spur64BitMemoryManager>>wordIndexableFormat (in category 'header formats') -----
+ wordIndexableFormat
+ ^self sixtyFourBitIndexableFormat!
Item was added:
+ ----- Method: Spur64BitMemoryManager>>wordSizeClassIndexPun (in category 'class table') -----
+ wordSizeClassIndexPun
+ ^self sixtyFourBitLongsClassIndexPun!
Item was changed:
CogClass subclass: #SpurMemoryManager
(excessive size, no diff calculated)
Item was changed:
----- Method: SpurMemoryManager>>allocateMemoryOfSize:newSpaceSize:stackSize:codeSize: (in category 'simulation') -----
allocateMemoryOfSize: memoryBytes newSpaceSize: newSpaceBytes stackSize: stackBytes codeSize: codeBytes
"Intialize the receiver for bootsraping an image.
Set up a large oldSpace and an empty newSpace and set-up freeStart and scavengeThreshold
to allocate in oldSpace. Later on (in initializePostBootstrap) freeStart and scavengeThreshold
will be set to sane values."
<doNotGenerate>
+ | endBridgeBytes |
self assert: (memoryBytes \\ self allocationUnit = 0
and: [newSpaceBytes \\ self allocationUnit = 0
and: [codeBytes \\ self allocationUnit = 0]]).
+ endBridgeBytes := 2 * self baseHeaderSize.
memory := (self endianness == #little
ifTrue: [LittleEndianBitmap]
+ ifFalse: [Bitmap]) new: (memoryBytes + newSpaceBytes + codeBytes + stackBytes + endBridgeBytes) // 4.
- ifFalse: [Bitmap]) new: (memoryBytes + newSpaceBytes + codeBytes + stackBytes) // 4.
startOfMemory := codeBytes + stackBytes.
endOfMemory := freeOldSpaceStart := memoryBytes + newSpaceBytes + codeBytes + stackBytes.
"leave newSpace empty for the bootstrap"
freeStart := newSpaceBytes + startOfMemory.
newSpaceLimit := newSpaceBytes + startOfMemory.
scavengeThreshold := memory size * 4. "Bitmap is a 4-byte per word array"
scavenger := SpurGenerationScavengerSimulator new
manager: self
newSpaceStart: startOfMemory
newSpaceBytes: newSpaceBytes
edenBytes: newSpaceBytes * 5 // 7 "David's paper uses 140Kb eden + 2 x 28kb survivor spaces :-)"!
Item was changed:
----- Method: SpurMemoryManager>>allocateOldSpaceChunkOfExactlyBytes: (in category 'free space') -----
allocateOldSpaceChunkOfExactlyBytes: chunkBytes
"Answer a chunk of oldSpace from the free lists, if one of this size
is available, otherwise answer nil. N.B. the chunk is simply a pointer,
it has no valid header. The caller *must* fill in the header correctly."
+ | initialIndex node nodeBytes parent child smaller larger |
- | initialIndex chunk nodeBytes parent child smaller larger |
"for debugging:" "totalFreeOldSpace := self totalFreeListBytes"
initialIndex := chunkBytes / self allocationUnit.
initialIndex < self numFreeLists ifTrue:
[(1 << initialIndex <= freeListsMask
+ and: [(node := freeLists at: initialIndex) ~= 0]) ifTrue:
+ [self assert: node = (self startOfObject: node).
+ self assert: (self isValidFreeObject: node).
- and: [(chunk := freeLists at: initialIndex) ~= 0]) ifTrue:
- [self assert: chunk = (self startOfObject: chunk).
- self assert: (self isValidFreeObject: chunk).
totalFreeOldSpace := totalFreeOldSpace - chunkBytes.
+ ^self unlinkFreeChunk: node atIndex: initialIndex].
- ^self unlinkFreeChunk: chunk atIndex: initialIndex].
^nil].
"Large chunk. Search the large chunk list.
Large chunk list organized as a tree, each node of which is a list of
chunks of the same size. Beneath the node are smaller and larger
blocks. When the search ends parent should hold the first chunk of
the same size as chunkBytes, or 0 if none."
+ node := 0.
- parent := chunk := 0.
child := freeLists at: 0.
[child ~= 0] whileTrue:
[| childBytes |
self assert: (self isValidFreeObject: child).
childBytes := self bytesInObject: child.
childBytes = chunkBytes
ifTrue: "size match; try to remove from list at node."
+ [node := self fetchPointer: self freeChunkNextIndex
- [chunk := self fetchPointer: self freeChunkNextIndex
ofFreeChunk: child.
+ node ~= 0 ifTrue:
+ [self assert: (self isValidFreeObject: node).
- chunk ~= 0 ifTrue:
- [self assert: (self isValidFreeObject: chunk).
self storePointer: self freeChunkNextIndex
ofFreeChunk: child
withValue: (self fetchPointer: self freeChunkNextIndex
+ ofFreeChunk: node).
- ofFreeChunk: chunk).
totalFreeOldSpace := totalFreeOldSpace - chunkBytes.
+ ^self startOfObject: node].
+ node := child.
+ nodeBytes := childBytes.
- ^self startOfObject: chunk].
child := 0] "break out of loop to remove interior node"
ifFalse:
[childBytes < chunkBytes
ifTrue: "walk down the tree"
[child := self fetchPointer: self freeChunkLargerIndex ofFreeChunk: child]
ifFalse:
+ [nodeBytes := childBytes.
- [parent := child.
- nodeBytes := childBytes.
child := self fetchPointer: self freeChunkSmallerIndex ofFreeChunk: child]]].
"if no chunk, there was no exact fit"
+ node = 0 ifTrue:
- chunk = 0 ifTrue:
[^nil].
"self printFreeChunk: parent"
self assert: nodeBytes = chunkBytes.
+ self assert: (self bytesInObject: node) = chunkBytes.
- self assert: (self bytesInObject: parent) = chunkBytes.
"can't be a list; would have removed and returned it above."
+ self assert: (self fetchPointer: self freeChunkNextIndex ofFreeChunk: node) = 0.
- self assert: (self fetchPointer: self freeChunkNextIndex ofFreeChunk: parent) = 0.
"no list; remove an interior node; reorder tree simply. two cases (which have mirrors, for four total):
case 1. interior node has one child, P = parent, N = node, S = subtree (mirrored for large vs small)
___ ___
| P | | P |
_/_ _/_
| N | => | S |
_/_
| S |
case 2: interior node has two children, , P = parent, N = node, L = smaller, left subtree, R = larger, right subtree.
add the left subtree to the bottom left of the right subtree (mirrored for large vs small)
___ ___
| P | | P |
_/_ _/_
| N | => | R |
_/_ _\_ _/_
| L | | R | | L |"
+ smaller := self fetchPointer: self freeChunkSmallerIndex ofFreeChunk: node.
+ larger := self fetchPointer: self freeChunkLargerIndex ofFreeChunk: node.
+ parent := self fetchPointer: self freeChunkParentIndex ofFreeChunk: node.
- chunk := parent.
- smaller := self fetchPointer: self freeChunkSmallerIndex ofFreeChunk: chunk.
- larger := self fetchPointer: self freeChunkLargerIndex ofFreeChunk: chunk.
- parent := self fetchPointer: self freeChunkParentIndex ofFreeChunk: chunk.
parent = 0
ifTrue: "no parent; stitch the subnodes back into the root"
[smaller = 0
ifTrue:
[self storePointer: self freeChunkParentIndex ofFreeChunk: larger withValue: 0.
freeLists at: 0 put: larger]
ifFalse:
[self storePointer: self freeChunkParentIndex ofFreeChunk: smaller withValue: 0.
freeLists at: 0 put: smaller.
larger ~= 0 ifTrue:
[self addFreeSubTree: larger]]]
ifFalse: "parent; stitch back into appropriate side of parent."
[smaller = 0
+ ifTrue: [self storePointer: (node = (self fetchPointer: self freeChunkSmallerIndex ofFreeChunk: parent)
- ifTrue: [self storePointer: (chunk = (self fetchPointer: self freeChunkSmallerIndex ofFreeChunk: parent)
ifTrue: [self freeChunkSmallerIndex]
ifFalse: [self freeChunkLargerIndex])
ofFreeChunk: parent
withValue: larger.
self storePointer: self freeChunkParentIndex
ofObject: larger
withValue: parent]
ifFalse:
+ [self storePointer: (node = (self fetchPointer: self freeChunkSmallerIndex ofFreeChunk: parent)
- [self storePointer: (chunk = (self fetchPointer: self freeChunkSmallerIndex ofFreeChunk: parent)
ifTrue: [self freeChunkSmallerIndex]
ifFalse: [self freeChunkLargerIndex])
ofFreeChunk: parent
withValue: smaller.
self storePointer: self freeChunkParentIndex
ofObject: smaller
withValue: parent.
larger ~= 0 ifTrue:
[self addFreeSubTree: larger]]].
+ ^self startOfObject: node!
- ^self startOfObject: chunk!
Item was changed:
+ ----- Method: SpurMemoryManager>>arrayClassIndexPun (in category 'class table puns') -----
- ----- Method: SpurMemoryManager>>arrayClassIndexPun (in category 'class table') -----
arrayClassIndexPun
"Class puns are class indices not used by any class. There is an entry
for the pun that refers to the notional class of objects with this class
index. But because the index doesn't match the class it won't show up
in allInstances, hence hiding the object with a pun as its class index.
The puns occupy indices 16 through 31."
^16!
Item was changed:
+ ----- Method: SpurMemoryManager>>classIsItselfClassIndexPun (in category 'class table puns') -----
- ----- Method: SpurMemoryManager>>classIsItselfClassIndexPun (in category 'class table') -----
classIsItselfClassIndexPun
^4!
Item was added:
+ ----- Method: SpurMemoryManager>>initSegmentBridgeWithBytes:at: (in category 'segments') -----
+ initSegmentBridgeWithBytes: numBytes at: address
+ <var: #numBytes type: #usqLong>
+ ^self subclassResponsibility!
Item was changed:
----- Method: SpurMemoryManager>>initialize (in category 'initialization') -----
initialize
+ "We can put all initializations that set something to 0 or to false here.
- "We can put all initializatins that set something to 0 or to false here.
In C all global variables are initialized to 0, and 0 is false."
remapBuffer := Array new: RemapBufferSize.
remapBufferCount := 0.
freeListsMask := totalFreeOldSpace := lowSpaceThreshold := 0.
checkForLeaks := 0.
needGCFlag := signalLowSpace := scavengeInProgress := false.
becomeEffectsFlags := 0.
statScavenges := statIncrGCs := statFullGCs := 0.
statScavengeGCUsecs := statIncrGCUsecs := statFullGCUsecs := 0.
statSGCDeltaUsecs := statIGCDeltaUsecs := statFGCDeltaUsecs := 0.
+ "we can initialize things that are virtual in C."
+ segmentManager := SpurSegmentManager new manager: self; yourself.
+
"We can also initialize here anything that is only for simulation."
heapMap := self wordSize = 4 ifTrue: [CogCheck32BitHeapMap new]!
Item was changed:
----- Method: SpurMemoryManager>>initializeOldSpaceFirstFree: (in category 'free space') -----
initializeOldSpaceFirstFree: startOfFreeOldSpace
<var: 'startOfFreeOldSpace' type: #usqLong>
| freeOldStart freeChunk |
<var: 'freeOldStart' type: #usqLong>
+
+ self initSegmentBridgeWithBytes: 2 * self baseHeaderSize at: endOfMemory.
-
endOfMemory > startOfFreeOldSpace ifTrue:
[totalFreeOldSpace := totalFreeOldSpace + (endOfMemory - startOfFreeOldSpace).
freeOldStart := startOfFreeOldSpace.
[endOfMemory - freeOldStart >= (2 raisedTo: 32)] whileTrue:
[freeChunk := self freeChunkWithBytes: (2 raisedTo: 32) at: freeOldStart.
freeOldStart := freeOldStart + (2 raisedTo: 32).
self assert: freeOldStart = (self addressAfter: freeChunk)].
freeOldStart < endOfMemory ifTrue:
[freeChunk := self freeChunkWithBytes: endOfMemory - freeOldStart at: freeOldStart.
self assert: (self addressAfter: freeChunk) = endOfMemory]].
freeOldSpaceStart := endOfMemory.
self checkFreeSpace!
Item was changed:
+ ----- Method: SpurMemoryManager>>isFreeObjectClassIndexPun (in category 'class table puns') -----
- ----- Method: SpurMemoryManager>>isFreeObjectClassIndexPun (in category 'class table') -----
isFreeObjectClassIndexPun
^0!
Item was added:
+ ----- Method: SpurMemoryManager>>isSegmentBridge: (in category 'segments') -----
+ isSegmentBridge: objOop
+ "Maybe this should be in SpurSegmentManager only"
+ ^(self classIndexOf: objOop) = self segmentBridgePun!
Item was removed:
- ----- Method: SpurMemoryManager>>isSegmentSpanningFakeObjectPun (in category 'class table') -----
- isSegmentSpanningFakeObjectPun
- ^3!
Item was added:
+ ----- Method: SpurMemoryManager>>isValidSegmentBridge: (in category 'segments') -----
+ isValidSegmentBridge: objOop
+ "Maybe this should be in SpurSegmentManager only"
+ ^(self addressCouldBeObj: objOop)
+ and: [(self isSegmentBridge: objOop)
+ and: [self hasOverflowHeader: objOop]]!
Item was added:
+ ----- Method: SpurMemoryManager>>segmentBridgePun (in category 'class table puns') -----
+ segmentBridgePun
+ ^3!
Item was added:
+ ----- Method: SpurMemoryManager>>segmentManager (in category 'accessing') -----
+ segmentManager
+ ^segmentManager!
Item was changed:
+ ----- Method: SpurMemoryManager>>sixtyFourBitLongsClassIndexPun (in category 'class table puns') -----
- ----- Method: SpurMemoryManager>>sixtyFourBitLongsClassIndexPun (in category 'class table') -----
sixtyFourBitLongsClassIndexPun
"Class puns are class indices not used by any class. There may be
an entry for the pun that refers to the notional class of objects with
this class index. But because the index doesn't match the class it
won't show up in allInstances, hence hiding the object with a pun as
its class index. The puns occupy indices 16 through 31."
^19!
Item was changed:
+ ----- Method: SpurMemoryManager>>thirtyTwoBitLongsClassIndexPun (in category 'class table puns') -----
- ----- Method: SpurMemoryManager>>thirtyTwoBitLongsClassIndexPun (in category 'class table') -----
thirtyTwoBitLongsClassIndexPun
"Class puns are class indices not used by any class. There may be
an entry for the pun that refers to the notional class of objects with
this class index. But because the index doesn't match the class it
won't show up in allInstances, hence hiding the object with a pun as
its class index. The puns occupy indices 16 through 31."
^18!
Item was changed:
+ ----- Method: SpurMemoryManager>>weakArrayClassIndexPun (in category 'class table puns') -----
- ----- Method: SpurMemoryManager>>weakArrayClassIndexPun (in category 'class table') -----
weakArrayClassIndexPun
"Class puns are class indices not used by any class. There is an entry
for the pun that refers to the notional class of objects with this class
index. But because the index doesn't match the class it won't show up
in allInstances, hence hiding the object with a pun as its class index.
The puns occupy indices 16 through 31."
^17!
Item was added:
+ ----- Method: SpurMemoryManager>>wordIndexableFormat (in category 'header formats') -----
+ wordIndexableFormat
+ "Either firstLongFormat or sixtyFourBitIndexableFormat"
+ ^self subclassResponsibility!
Item was added:
+ ----- Method: SpurMemoryManager>>wordSizeClassIndexPun (in category 'class table puns') -----
+ wordSizeClassIndexPun
+ ^self subclassResponsibility!
Item was added:
+ ----- Method: SpurSegmentManager>>initializeFromFreeChunks: (in category 'simulation only') -----
+ initializeFromFreeChunks: freeChunks
+ "For testing, create a set of segments using the freeChunks as bridges."
+ numSegments := freeChunks size.
+ freeChunks do:
+ [:f|
+ manager initSegmentBridgeWithBytes: (manager bytesInObject: f) at: (manager startOfObject: f).
+ self assert: (manager isSegmentBridge: f)].
+ segments := (1 to: numSegments) collect:
+ [:i| | start |
+ start := i = 1
+ ifTrue: [manager newSpaceLimit]
+ ifFalse: [manager addressAfter: (freeChunks at: i - 1)].
+ SpurSegmentInfo new
+ start: start;
+ segSize: (freeChunks at: i) + manager baseHeaderSize - start;
+ yourself].
+ segments := CArrayAccessor on: segments.
+ freeChunks do:
+ [:bridge| self assert: (manager isValidSegmentBridge: bridge)]!
Item was added:
+ ----- Method: SpurSegmentManager>>manager: (in category 'initialization') -----
+ manager: aSpurMemoryManager
+ manager := aSpurMemoryManager.
+ numSegments ifNil:
+ [numSegments := 0]!
Item was added:
+ ----- 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 + BaseHeaderSize.
+ self longAt: obj + BaseHeaderSize put: (self longAt: obj + BaseHeaderSize + 4).
+ self longAt: obj + BaseHeaderSize + 4 put: temp]]!
Item was removed:
- ----- Method: StackInterpreter>>convertFloatsToPlatformOrderFrom:to: (in category 'image save/restore') -----
- convertFloatsToPlatformOrderFrom: startOop to: stopAddr
- "Byte-swap the words of all bytes objects in a range of the
- image, including Strings, ByteArrays, and CompiledMethods.
- This returns these objects to their original byte ordering
- after blindly byte-swapping the entire image. For compiled
- methods, byte-swap only their bytecodes part.
- Ensure floats are in platform-order."
- objectMemory vmEndianness = imageFloatsBigEndian ifTrue:
- [^nil].
- self assert: ClassFloatCompactIndex ~= 0.
- objectMemory allObjectsDo:
- [:obj| | temp |
- (objectMemory compactClassIndexOf: obj) = ClassFloatCompactIndex ifTrue:
- [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>>ensureImageFormatIsUpToDate: (in category 'image save/restore') -----
ensureImageFormatIsUpToDate: swapBytes
"Ensure the image data has been updayed to suit the current VM."
<inline: false>
swapBytes
ifTrue: [self reverseBytesInImage]
+ ifFalse: [self convertFloatsToPlatformOrder]!
- ifFalse: [self convertFloatsToPlatformOrderFrom: objectMemory firstObject to: objectMemory freeStart]!
1
0
Eliot Miranda uploaded a new version of Cog to project VM Maker:
http://source.squeak.org/VMMaker/Cog-eem.107.mcz
==================== Summary ====================
Name: Cog-eem.107
Author: eem
Time: 8 October 2013, 2:55:03.033 pm
UUID: eb9867bb-181f-4ddd-8f17-753aa210f90f
Ancestors: Cog-eem.106
Use neater wordSizeClassIndexPun & wordIndexableFormat for
free list bootstrap.
Add a "test" to write a segmented snapshot file.
=============== Diff against Cog-eem.106 ===============
Item was changed:
----- Method: SpurBootstrap>>allocateFreeLists (in category 'bootstrap image') -----
allocateFreeLists
"Allocate the freeLists array."
| freeListsOop |
freeListsOop := newHeap
allocateSlots: newHeap numFreeLists
+ format: newHeap wordIndexableFormat
+ classIndex: newHeap wordSizeClassIndexPun.
- format: (newHeap wordSize = 4
- ifTrue: [newHeap firstLongFormat]
- ifFalse: [newHeap sixtyFourBitIndexableFormat])
- classIndex: (newHeap wordSize = 4
- ifTrue: [newHeap thirtyTwoBitLongsClassIndexPun]
- ifFalse: [newHeap sixtyFourBitLongsClassIndexPun]).
self assert: (newHeap objectAfter: newHeap trueObject) = freeListsOop.
0 to: newHeap numFreeLists - 1 do:
[:i|
newHeap
storePointerUnchecked: freeListsOop
ofObject: freeListsOop
withValue: 0]!
Item was added:
+ ----- Method: SpurBootstrap>>writeSnapshotOfTransformedImage (in category 'testing') -----
+ writeSnapshotOfTransformedImage
+ "The bootstrapped image typically contains a few big free chunks and one huge free chunk.
+ Test snapshot writing and loading by turning the largest non-huge chunks into segment bridges
+ and saving."
+ | heap sizes counts barriers sim |
+ heap := TransformedImage veryDeepCopy.
+ sim := StackInterpreterSimulator onObjectMemory: heap.
+ heap coInterpreter: sim.
+ sim initializeInterpreter: 0.
+ sizes := Bag new.
+ heap allObjectsInFreeTree: (heap freeLists at: 0) do:
+ [:f|
+ sizes add: (heap bytesInObject: f)].
+ counts := sizes sortedCounts.
+ self assert: counts last key = 1. "1 huge chunk"
+ self assert: ((counts at: counts size - 1) key > 2
+ and: [(counts at: counts size - 1) value > 1024]).
+ barriers := (1 to: (counts at: counts size - 1) key) collect:
+ [:ign| heap allocateOldSpaceChunkOfExactlyBytes: (counts at: counts size - 1) value].
+ heap segmentManager initializeFromFreeChunks: (barriers sort collect: [:b| heap objectStartingAt: b]).
+ sim imageName: 'spur.image'.
+ sim writeImageFileIO: heap !
1
0
I spent some time setting up a git tracker for the cog svn repository.
This should help us reducing the merge errors for the pharo-vm, when picking changes
from eliot's branch on http://squeakvm.org/svn/squeak/branches/Cog
It takes a prepared zip with the proper meta information for git-svn from here
http://files.pharo.org/vm/src/cog-git-svn-track.zip
and updates the separate repositories from the github squeakvm project
http://github.com/squeakvm/
Currently this is a very fragile setup, since git and svn:externals are not very
compatible. However, it does the trick for our purposes.
The following steps are run on a daily basis:
---------------------------------------------
https://ci.inria.fr/pharo/view/Helper/job/Cog-SVN-Tracker/
1. update both of the commonly shared plugin directories
2. fetch on the latest svn version on the 'svn' for cog
3. load the plugin repositories in with 'git subtree' on the 'master' branch on cog
4. merge the 'master' branch with the 'svn' branch
5. push
Steps to do
-----------
- setup a proper mergepoint somewhere in the past of pharo-vm (that requires git black magic)
- pharo-vm has to merge with the latest changes from cog (that requires VM knowledge)
1
0
Eliot Miranda uploaded a new version of Cog to project VM Maker:
http://source.squeak.org/VMMaker/Cog-eem.106.mcz
==================== Summary ====================
Name: Cog-eem.106
Author: eem
Time: 8 October 2013, 10:43:28.787 am
UUID: f62ab9c1-dec9-4bd3-93ea-b8506da65428
Ancestors: Cog-ClementBera.105
Merge with Cog-ClementBera.105. Fix a Stream extension category name.
Spur Bootstrap:
Move freeLists to heap, immediately following trueObj.
Make freeLists size of a machine word. 98.8% of objects are <= 31
allocationUnits in size in the 32-bit VM. So making freeListsMask
64-bits doesn't make sense. Best keep it in 32-bits and have it fit
in a register.
=============== Diff against Cog-ClementBera.105 ===============
Item was changed:
SystemOrganization addCategory: #Cog!
SystemOrganization addCategory: #'Cog-Benchmarks-DeltaBlue'!
SystemOrganization addCategory: #'Cog-Benchmarks-Richards'!
SystemOrganization addCategory: #'Cog-Benchmarks-SMark'!
SystemOrganization addCategory: #'Cog-Benchmarks-Shootout'!
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-Benchmarks'!
Item was added:
+ ----- Method: SpurBootstrap>>allocateFreeLists (in category 'bootstrap image') -----
+ allocateFreeLists
+ "Allocate the freeLists array."
+ | freeListsOop |
+ freeListsOop := newHeap
+ allocateSlots: newHeap numFreeLists
+ format: (newHeap wordSize = 4
+ ifTrue: [newHeap firstLongFormat]
+ ifFalse: [newHeap sixtyFourBitIndexableFormat])
+ classIndex: (newHeap wordSize = 4
+ ifTrue: [newHeap thirtyTwoBitLongsClassIndexPun]
+ ifFalse: [newHeap sixtyFourBitLongsClassIndexPun]).
+ self assert: (newHeap objectAfter: newHeap trueObject) = freeListsOop.
+ 0 to: newHeap numFreeLists - 1 do:
+ [:i|
+ newHeap
+ storePointerUnchecked: freeListsOop
+ ofObject: freeListsOop
+ withValue: 0]!
Item was changed:
----- Method: SpurBootstrap>>bootstrapImage (in category 'bootstrap image') -----
bootstrapImage
oldHeap fullGC.
oldHeapSize := oldHeap freeStart.
Transcript cr; nextPutAll: 'transforming image...'; flush.
self cloneNilTrueAndFalse.
+ self allocateFreeLists.
self buildClassMap.
self allocateClassTable.
self cloneObjects.
self fillInObjects.
self fillInClassTable.
newHeapSize := newHeap freeStart.
newHeap initializePostBootstrap!
Item was changed:
----- Method: SpurBootstrap>>validate (in category 'bootstrap image') -----
validate
| p n duplicates maxClassIndex |
self assert: (reverseMap at: newHeap specialObjectsOop) = oldHeap specialObjectsOop.
self assert: (map at: oldHeap specialObjectsOop) = newHeap specialObjectsOop.
self assert: (reverseMap at: newHeap classTableRootObj ifAbsent: []) isNil.
duplicates := { 3. newHeap arrayClassIndexPun. newHeap weakArrayClassIndexPun }.
maxClassIndex := classToIndex inject: 0 into: [:a :b| a max: b].
self assert: ((newHeap arrayClassIndexPun to: maxClassIndex) select:
[:idx| | classObj |
(classObj := newHeap classAtIndex: idx) ~= newHeap nilObject
and: [(newHeap classIndexOf: classObj) = (newHeap rawHashBitsOf: classObj)]]) isEmpty.
0 to: maxClassIndex do:
[:index| | classObj |
(index <= newHeap tagMask
and: [index > newHeap isForwardedObjectClassIndexPun]) ifTrue:
[(classObj := newHeap classAtIndex: index) = newHeap nilObject
ifTrue:
[self assert: (classToIndex keyAtValue: index ifAbsent: []) isNil]
ifFalse:
[self assert: (newHeap classIndexOf: classObj) ~= (newHeap rawHashBitsOf: classObj).
(duplicates includes: index) ifFalse:
[self assert: (newHeap rawHashBitsOf: classObj) = index]]]].
classToIndex keysAndValuesDo:
[:oldClass :idx|
self assert: (newHeap rawHashBitsOf: (map at: oldClass)) = idx.
self assert: oldClass = (reverseMap at: (newHeap classAtIndex: idx))].
n := 0.
newHeap allObjectsDo:
[:o|
(o <= newHeap trueObject
or: [o > lastClassTablePage]) ifTrue:
[self assert: (reverseMap includesKey: o).
self assert: (newHeap fetchClassOfNonImm: o) = (map at: (oldHeap fetchClassOfNonImm: (reverseMap at: o)))].
n := n + 1.
p := o].
p class.
+ self assert: (n between: map size and: map size + 6). "+ 6 is room for freelists & classTable"
- self assert: (n between: map size and: map size + 5). "+ 5 is room for classTable"
"check some class properties to ensure the format changes are correct"
self assert: (newHeap fixedFieldsOfClassFormat: (newHeap formatOfClass: newHeap classArray)) = 0.
self assert: (newHeap instSpecOfClassFormat: (newHeap formatOfClass: newHeap classArray)) = newHeap arrayFormat!
Item was changed:
+ ----- Method: Stream>>nl (in category '*Cog-Benchmarks-Shootout-platform') -----
- ----- Method: Stream>>nl (in category '*Cog-Benchmarks-Shootout-Shootout-Shootout-platform') -----
nl
self nextPut: Character lf!
Item was changed:
+ ----- Method: Stream>>print:digits: (in category '*Cog-Benchmarks-Shootout-platform') -----
- ----- Method: Stream>>print:digits: (in category '*Cog-Benchmarks-Shootout-Shootout-Shootout-platform') -----
print: number digits: decimalPlaces
| precision rounded |
decimalPlaces <= 0 ifTrue: [^ number rounded printString].
precision := Utilities floatPrecisionForDecimalPlaces: decimalPlaces.
rounded := number roundTo: precision.
self nextPutAll:
((rounded asScaledDecimal: decimalPlaces) printString copyUpTo: $s)!
Item was changed:
+ ----- Method: Stream>>print:paddedTo: (in category '*Cog-Benchmarks-Shootout-platform') -----
- ----- Method: Stream>>print:paddedTo: (in category '*Cog-Benchmarks-Shootout-Shootout-Shootout-platform') -----
print: number paddedTo: width
self nextPutAll: (number printStringLength: width padded: false)!
1
0
Eliot Miranda uploaded a new version of VMMaker to project VM Maker:
http://source.squeak.org/VMMaker/VMMaker.oscog-eem.440.mcz
==================== Summary ====================
Name: VMMaker.oscog-eem.440
Author: eem
Time: 8 October 2013, 10:36:50.516 am
UUID: 6c650edc-83c9-42c3-bd6f-f22edc1304ed
Ancestors: VMMaker.oscog-eem.439
Move freeLists to heap, immediately following trueObj.
Make freeLists size of a machibe word. 98.8% of objects are <= 31
allocationUnits in size in the 32-bit VM. So making freeListsMask
64-bits doesn't make sense. Best keep it in 32-bits and have it fit
in a register.
=============== Diff against VMMaker.oscog-eem.439 ===============
Item was added:
+ ----- Method: Spur32BitMemoryManager>>numFreeLists (in category 'free space') -----
+ numFreeLists
+ "Answer the number of free lists. We use freeListsMask, a bitmap, to avoid
+ reading empty list heads. This hsould fit in a machine word to end up in a
+ register during free chunk allocation."
+ ^32!
Item was added:
+ ----- Method: Spur64BitMemoryManager>>numFreeLists (in category 'free space') -----
+ numFreeLists
+ "Answer the number of free lists. We use freeListsMask, a bitmap, to avoid
+ reading empty list heads. This hsould fit in a machine word to end up in a
+ register during free chunk allocation."
+ ^64!
Item was changed:
CogClass subclass: #SpurMemoryManager
(excessive size, no diff calculated)
Item was changed:
----- Method: SpurMemoryManager class>>initialize (in category 'class initialization') -----
initialize
"CogObjectMemory initialize"
- NumFreeLists := 65. "One for each size up to and including 64 slots. One for sizes > 64 slots."
CheckObjectOverwrite := true.
"The remap buffer support is for compatibility; Spur doesn't GC during allocation.
Eventually this should die."
RemapBufferSize := 25!
Item was changed:
----- Method: SpurMemoryManager>>addToFreeList:bytes: (in category 'free space') -----
addToFreeList: freeChunk bytes: chunkBytes
| childBytes parent child index |
"coInterpreter transcript ensureCr. coInterpreter print: 'freeing '. self printFreeChunk: freeChunk."
self assert: (self isFreeObject: freeChunk).
self assert: chunkBytes = (self bytesInObject: freeChunk).
index := chunkBytes / self allocationUnit.
+ index < self numFreeLists ifTrue:
- index < NumFreeLists ifTrue:
[self storePointer: self freeChunkNextIndex ofFreeChunk: freeChunk withValue: (freeLists at: index).
freeLists at: index put: freeChunk.
freeListsMask := freeListsMask bitOr: 1 << index.
^self].
freeListsMask := freeListsMask bitOr: 1.
self
storePointer: self freeChunkNextIndex ofFreeChunk: freeChunk withValue: 0;
storePointer: self freeChunkParentIndex ofFreeChunk: freeChunk withValue: 0;
storePointer: self freeChunkSmallerIndex ofFreeChunk: freeChunk withValue: 0;
storePointer: self freeChunkLargerIndex ofFreeChunk: freeChunk withValue: 0.
"Large chunk list organized as a tree, each node of which is a list of chunks of the same size.
Beneath the node are smaller and larger blocks."
parent := 0.
child := freeLists at: 0.
[child ~= 0] whileTrue:
[childBytes := self bytesInObject: child.
childBytes = chunkBytes ifTrue: "size match; add to list at node."
[self storePointer: self freeChunkNextIndex
ofFreeChunk: freeChunk
withValue: (self fetchPointer: self freeChunkNextIndex ofObject: child);
storePointer: self freeChunkNextIndex
ofFreeChunk: child
withValue: freeChunk.
^self].
"walk down the tree"
parent := child.
child := self fetchPointer: (childBytes > chunkBytes
ifTrue: [self freeChunkSmallerIndex]
ifFalse: [self freeChunkLargerIndex])
ofObject: child].
parent = 0 ifTrue:
[self assert: (freeLists at: 0) = 0.
freeLists at: 0 put: freeChunk.
^self].
"insert in tree"
self storePointer: self freeChunkParentIndex
ofFreeChunk: freeChunk
withValue: parent.
self storePointer: (childBytes > chunkBytes
ifTrue: [self freeChunkSmallerIndex]
ifFalse: [self freeChunkLargerIndex])
ofFreeChunk: parent
withValue: freeChunk!
Item was changed:
----- Method: SpurMemoryManager>>allFreeObjectsDo: (in category 'free space') -----
allFreeObjectsDo: aBlock
| obj |
+ 1 to: self numFreeLists - 1 do:
- 1 to: NumFreeLists - 1 do:
[:i|
obj := freeLists at: i.
[obj ~= 0] whileTrue:
[aBlock value: obj.
obj := self fetchPointer: self freeChunkNextIndex ofFreeChunk: obj]].
self allObjectsInFreeTree: (freeLists at: 0) do: aBlock!
Item was changed:
----- Method: SpurMemoryManager>>allocateOldSpaceChunkOfBytes: (in category 'free space') -----
allocateOldSpaceChunkOfBytes: chunkBytes
"Answer a chunk of oldSpace from the free lists, if available,
otherwise answer nil. Break up a larger chunk if one of the
exact size does not exist. N.B. the chunk is simply a pointer, it
has no valid header. The caller *must* fill in the header correctly."
| initialIndex chunk index nodeBytes parent child smaller larger |
"for debugging:" "totalFreeOldSpace := self totalFreeListBytes"
totalFreeOldSpace := totalFreeOldSpace - chunkBytes. "be optimistic (& don't wait for the write)"
initialIndex := chunkBytes / self allocationUnit.
+ (initialIndex < self numFreeLists and: [1 << initialIndex <= freeListsMask]) ifTrue:
- (initialIndex < NumFreeLists and: [1 << initialIndex <= freeListsMask]) ifTrue:
[(freeListsMask anyMask: 1 << initialIndex) ifTrue:
[(chunk := freeLists at: initialIndex) ~= 0 ifTrue:
[self assert: chunk = (self startOfObject: chunk).
self assert: (self isValidFreeObject: chunk).
^self unlinkFreeChunk: chunk atIndex: initialIndex].
freeListsMask := freeListsMask - (1 << initialIndex)].
"first search for free chunks of a multiple of chunkBytes in size"
index := initialIndex.
+ [(index := index + index) < self numFreeLists
- [(index := index + index) < NumFreeLists
and: [1 << index <= freeListsMask]] whileTrue:
[((freeListsMask anyMask: 1 << index)
and: [(chunk := freeLists at: index) ~= 0]) ifTrue:
[self assert: chunk = (self startOfObject: chunk).
self assert: (self isValidFreeObject: chunk).
self unlinkFreeChunk: chunk atIndex: index.
self assert: (self bytesInObject: chunk) = (index * self allocationUnit).
self freeChunkWithBytes: index * self allocationUnit - chunkBytes
at: (self startOfObject: chunk) + chunkBytes.
^chunk]].
"now get desperate and use the first that'll fit.
Note that because the minimum free size is 16 bytes (2 * allocationUnit), to
leave room for the forwarding pointer/next free link, we can only break chunks
that are at least 16 bytes larger, hence start at initialIndex + 2."
index := initialIndex + 1.
+ [(index := index + 1) < self numFreeLists
- [(index := index + 1) < NumFreeLists
and: [1 << index <= freeListsMask]] whileTrue:
[(freeListsMask anyMask: 1 << index) ifTrue:
[(chunk := freeLists at: index) ~= 0 ifTrue:
[self assert: chunk = (self startOfObject: chunk).
self assert: (self isValidFreeObject: chunk).
self unlinkFreeChunk: chunk atIndex: index.
self assert: (self bytesInObject: chunk) = (index * self allocationUnit).
self freeChunkWithBytes: index * self allocationUnit - chunkBytes
at: (self startOfObject: chunk) + chunkBytes.
^chunk].
freeListsMask := freeListsMask - (1 << index)]]].
"Large chunk, or no space on small free lists. Search the large chunk list.
Large chunk list organized as a tree, each node of which is a list of chunks
of the same size. Beneath the node are smaller and larger blocks.
When the search ends parent should hold the smallest chunk at least as
large as chunkBytes, or 0 if none."
parent := 0.
child := freeLists at: 0.
[child ~= 0] whileTrue:
[| childBytes |
self assert: (self isValidFreeObject: child).
childBytes := self bytesInObject: child.
childBytes = chunkBytes
ifTrue: "size match; try to remove from list at node."
[chunk := self fetchPointer: self freeChunkNextIndex
ofFreeChunk: child.
chunk ~= 0 ifTrue:
[self assert: (self isValidFreeObject: chunk).
self storePointer: self freeChunkNextIndex
ofFreeChunk: child
withValue: (self fetchPointer: self freeChunkNextIndex
ofFreeChunk: chunk).
^self startOfObject: chunk].
child := 0] "break out of loop to remove interior node"
ifFalse:
["Note that because the minimum free size is 16 bytes (2 * allocationUnit), to
leave room for the forwarding pointer/next free link, we can only break chunks
that are at least 16 bytes larger, hence reject chunks < 2 * allocationUnit larger."
childBytes <= (chunkBytes + self allocationUnit)
ifTrue: "node too small; walk down the larger size of the tree"
[child := self fetchPointer: self freeChunkLargerIndex ofFreeChunk: child]
ifFalse:
[parent := child. "parent will be smallest node >= chunkBytes + allocationUnit"
nodeBytes := childBytes.
child := self fetchPointer: self freeChunkSmallerIndex ofFreeChunk: child]]].
parent = 0 ifTrue:
[totalFreeOldSpace := totalFreeOldSpace + chunkBytes. "optimism was unfounded"
self halt.
^nil].
"self printFreeChunk: parent"
self assert: (nodeBytes = chunkBytes or: [nodeBytes >= (chunkBytes + (2 * self allocationUnit))]).
self assert: (self bytesInObject: parent) = nodeBytes.
"attempt to remove from list"
chunk := self fetchPointer: self freeChunkNextIndex
ofFreeChunk: parent.
chunk ~= 0 ifTrue:
[self assert: (chunkBytes = nodeBytes or: [chunkBytes + self allocationUnit < nodeBytes]).
self storePointer: self freeChunkNextIndex
ofFreeChunk: parent
withValue: (self fetchPointer: self freeChunkNextIndex
ofFreeChunk: chunk).
chunkBytes ~= nodeBytes ifTrue:
[self freeChunkWithBytes: nodeBytes - chunkBytes
at: (self startOfObject: chunk) + chunkBytes].
^self startOfObject: chunk].
"no list; remove an interior node; reorder tree simply. two cases (which have mirrors, for four total):
case 1. interior node has one child, P = parent, N = node, S = subtree (mirrored for large vs small)
___ ___
| P | | P |
_/_ _/_
| N | => | S |
_/_
| S |
case 2: interior node has two children, , P = parent, N = node, L = smaller, left subtree, R = larger, right subtree.
add the left subtree to the bottom left of the right subtree (mirrored for large vs small)
___ ___
| P | | P |
_/_ _/_
| N | => | R |
_/_ _\_ _/_
| L | | R | | L |"
chunk := parent.
smaller := self fetchPointer: self freeChunkSmallerIndex ofFreeChunk: chunk.
larger := self fetchPointer: self freeChunkLargerIndex ofFreeChunk: chunk.
parent := self fetchPointer: self freeChunkParentIndex ofFreeChunk: chunk.
parent = 0
ifTrue: "no parent; stitch the subnodes back into the root"
[smaller = 0
ifTrue:
[self storePointer: self freeChunkParentIndex ofFreeChunk: larger withValue: 0.
freeLists at: 0 put: larger]
ifFalse:
[self storePointer: self freeChunkParentIndex ofFreeChunk: smaller withValue: 0.
freeLists at: 0 put: smaller.
larger ~= 0 ifTrue:
[self addFreeSubTree: larger]]]
ifFalse: "parent; stitch back into appropriate side of parent."
[smaller = 0
ifTrue: [self storePointer: (chunk = (self fetchPointer: self freeChunkSmallerIndex ofFreeChunk: parent)
ifTrue: [self freeChunkSmallerIndex]
ifFalse: [self freeChunkLargerIndex])
ofFreeChunk: parent
withValue: larger.
self storePointer: self freeChunkParentIndex
ofObject: larger
withValue: parent]
ifFalse:
[self storePointer: (chunk = (self fetchPointer: self freeChunkSmallerIndex ofFreeChunk: parent)
ifTrue: [self freeChunkSmallerIndex]
ifFalse: [self freeChunkLargerIndex])
ofFreeChunk: parent
withValue: smaller.
self storePointer: self freeChunkParentIndex
ofObject: smaller
withValue: parent.
larger ~= 0 ifTrue:
[self addFreeSubTree: larger]]].
"if there's space left over, add the fragment back."
chunkBytes ~= nodeBytes ifTrue:
[self freeChunkWithBytes: nodeBytes - chunkBytes
at: (self startOfObject: chunk) + chunkBytes].
^self startOfObject: chunk!
Item was changed:
----- Method: SpurMemoryManager>>allocateOldSpaceChunkOfExactlyBytes: (in category 'free space') -----
allocateOldSpaceChunkOfExactlyBytes: chunkBytes
"Answer a chunk of oldSpace from the free lists, if one of this size
is available, otherwise answer nil. N.B. the chunk is simply a pointer,
it has no valid header. The caller *must* fill in the header correctly."
| initialIndex chunk nodeBytes parent child smaller larger |
"for debugging:" "totalFreeOldSpace := self totalFreeListBytes"
initialIndex := chunkBytes / self allocationUnit.
+ initialIndex < self numFreeLists ifTrue:
- initialIndex < NumFreeLists ifTrue:
[(1 << initialIndex <= freeListsMask
and: [(chunk := freeLists at: initialIndex) ~= 0]) ifTrue:
[self assert: chunk = (self startOfObject: chunk).
self assert: (self isValidFreeObject: chunk).
totalFreeOldSpace := totalFreeOldSpace - chunkBytes.
^self unlinkFreeChunk: chunk atIndex: initialIndex].
^nil].
"Large chunk. Search the large chunk list.
Large chunk list organized as a tree, each node of which is a list of
chunks of the same size. Beneath the node are smaller and larger
blocks. When the search ends parent should hold the first chunk of
the same size as chunkBytes, or 0 if none."
parent := chunk := 0.
child := freeLists at: 0.
[child ~= 0] whileTrue:
[| childBytes |
self assert: (self isValidFreeObject: child).
childBytes := self bytesInObject: child.
childBytes = chunkBytes
ifTrue: "size match; try to remove from list at node."
[chunk := self fetchPointer: self freeChunkNextIndex
ofFreeChunk: child.
chunk ~= 0 ifTrue:
[self assert: (self isValidFreeObject: chunk).
self storePointer: self freeChunkNextIndex
ofFreeChunk: child
withValue: (self fetchPointer: self freeChunkNextIndex
ofFreeChunk: chunk).
totalFreeOldSpace := totalFreeOldSpace - chunkBytes.
^self startOfObject: chunk].
child := 0] "break out of loop to remove interior node"
ifFalse:
[childBytes < chunkBytes
ifTrue: "walk down the tree"
[child := self fetchPointer: self freeChunkLargerIndex ofFreeChunk: child]
ifFalse:
[parent := child.
nodeBytes := childBytes.
child := self fetchPointer: self freeChunkSmallerIndex ofFreeChunk: child]]].
"if no chunk, there was no exact fit"
chunk = 0 ifTrue:
[^nil].
"self printFreeChunk: parent"
self assert: nodeBytes = chunkBytes.
self assert: (self bytesInObject: parent) = chunkBytes.
"can't be a list; would have removed and returned it above."
self assert: (self fetchPointer: self freeChunkNextIndex ofFreeChunk: parent) = 0.
"no list; remove an interior node; reorder tree simply. two cases (which have mirrors, for four total):
case 1. interior node has one child, P = parent, N = node, S = subtree (mirrored for large vs small)
___ ___
| P | | P |
_/_ _/_
| N | => | S |
_/_
| S |
case 2: interior node has two children, , P = parent, N = node, L = smaller, left subtree, R = larger, right subtree.
add the left subtree to the bottom left of the right subtree (mirrored for large vs small)
___ ___
| P | | P |
_/_ _/_
| N | => | R |
_/_ _\_ _/_
| L | | R | | L |"
chunk := parent.
smaller := self fetchPointer: self freeChunkSmallerIndex ofFreeChunk: chunk.
larger := self fetchPointer: self freeChunkLargerIndex ofFreeChunk: chunk.
parent := self fetchPointer: self freeChunkParentIndex ofFreeChunk: chunk.
parent = 0
ifTrue: "no parent; stitch the subnodes back into the root"
[smaller = 0
ifTrue:
[self storePointer: self freeChunkParentIndex ofFreeChunk: larger withValue: 0.
freeLists at: 0 put: larger]
ifFalse:
[self storePointer: self freeChunkParentIndex ofFreeChunk: smaller withValue: 0.
freeLists at: 0 put: smaller.
larger ~= 0 ifTrue:
[self addFreeSubTree: larger]]]
ifFalse: "parent; stitch back into appropriate side of parent."
[smaller = 0
ifTrue: [self storePointer: (chunk = (self fetchPointer: self freeChunkSmallerIndex ofFreeChunk: parent)
ifTrue: [self freeChunkSmallerIndex]
ifFalse: [self freeChunkLargerIndex])
ofFreeChunk: parent
withValue: larger.
self storePointer: self freeChunkParentIndex
ofObject: larger
withValue: parent]
ifFalse:
[self storePointer: (chunk = (self fetchPointer: self freeChunkSmallerIndex ofFreeChunk: parent)
ifTrue: [self freeChunkSmallerIndex]
ifFalse: [self freeChunkLargerIndex])
ofFreeChunk: parent
withValue: smaller.
self storePointer: self freeChunkParentIndex
ofObject: smaller
withValue: parent.
larger ~= 0 ifTrue:
[self addFreeSubTree: larger]]].
^self startOfObject: chunk!
Item was changed:
----- Method: SpurMemoryManager>>bitsSetInFreeSpaceMaskForAllFreeLists (in category 'debug support') -----
bitsSetInFreeSpaceMaskForAllFreeLists
+ 0 to: self numFreeLists - 1 do:
- 0 to: NumFreeLists - 1 do:
[:i|
((freeLists at: i) ~= 0
and: [1 << i noMask: freeListsMask]) ifTrue:
[^false]].
^true!
Item was changed:
----- Method: SpurMemoryManager>>bytesInFreeTree: (in category 'free space') -----
bytesInFreeTree: freeNode
| freeBytes bytesInObject listNode |
freeNode = 0 ifTrue: [^0].
freeBytes := 0.
bytesInObject := self bytesInObject: freeNode.
+ self assert: bytesInObject / self allocationUnit >= self numFreeLists.
- self assert: bytesInObject / self allocationUnit >= NumFreeLists.
listNode := freeNode.
[listNode ~= 0] whileTrue:
["self printFreeChunk: listNode"
self assert: (self isValidFreeObject: listNode).
freeBytes := freeBytes + bytesInObject.
self assert: bytesInObject = (self bytesInObject: listNode).
listNode := self fetchPointer: self freeChunkNextIndex ofFreeChunk: listNode].
^freeBytes
+ (self bytesInFreeTree: (self fetchPointer: self freeChunkSmallerIndex ofFreeChunk: freeNode))
+ (self bytesInFreeTree: (self fetchPointer: self freeChunkLargerIndex ofFreeChunk: freeNode))!
Item was changed:
----- Method: SpurMemoryManager>>checkHeapIntegrity (in category 'debug support') -----
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."
| prevObj prevPrevObj ok numRememberedRootsInHeap |
<inline: false>
ok := true.
numRememberedRootsInHeap := 0.
self allHeapEntitiesDo:
[:obj| | containsYoung fieldOop classIndex classOop |
(self isFreeObject: obj) ifFalse:
[containsYoung := false.
(self isRemembered: obj) ifTrue:
[numRememberedRootsInHeap := numRememberedRootsInHeap + 1.
(scavenger isInRememberedTable: obj) ifFalse:
[coInterpreter print: 'remembered object '; printHex: obj; print: ' is not in remembered table'; cr.
self eek.
ok := false]].
(self isForwarded: obj)
ifTrue:
[fieldOop := self fetchPointer: 0 ofMaybeForwardedObject: obj.
(heapMap heapMapAtWord: (self pointerForOop: fieldOop)) = 0 ifTrue:
[coInterpreter print: 'object leak in forwarder '; printHex: obj; print: ' to unmapped '; printHex: fieldOop; cr.
self eek.
ok := false].
(self isYoung: fieldOop) ifTrue:
[containsYoung := true]]
ifFalse:
[classOop := self classAtIndex: (classIndex := self classIndexOf: obj).
+ ((classOop isNil or: [classOop = nilObj])
+ and: [obj ~= self freeListsObject]) ifTrue:
- (classOop isNil or: [classOop = nilObj]) ifTrue:
[coInterpreter print: 'object leak in '; printHex: obj; print: ' invalid class index '; printHex: classIndex; print: ' -> '; print: (classOop ifNil: ['nil'] ifNotNil: ['nilObj']); cr.
self eek.
ok := false].
self baseHeaderSize to: (self lastPointerOf: obj) by: BytesPerOop do:
[:ptr|
fieldOop := self longAt: obj + ptr.
(self isNonImmediate: fieldOop) ifTrue:
[| fi |
fi := ptr - self baseHeaderSize / self wordSize.
(fieldOop bitAnd: self wordSize - 1) ~= 0
ifTrue:
[coInterpreter 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:
[coInterpreter print: 'object leak in '; printHex: obj; print: ' @ '; printNum: fi; print: ' = '; printHex: fieldOop; cr.
self eek.
ok := false].
"don't be misled by CogMethods; they appear to be young, but they're not"
((self isYoung: fieldOop) and: [fieldOop >= startOfMemory]) ifTrue:
[containsYoung := true]]]]].
(containsYoung and: [(self isYoung: obj) not]) ifTrue:
[(self isRemembered: obj) ifFalse:
[coInterpreter print: 'unremembered object '; printHex: obj; print: ' contains young oop(s)'; cr.
self eek.
ok := false]]].
prevPrevObj := prevObj.
prevObj := obj].
numRememberedRootsInHeap ~= scavenger rememberedSetSize ifTrue:
[coInterpreter
print: 'root count mismatch. #heap roots ';
printNum: numRememberedRootsInHeap;
print: '; #roots ';
printNum: scavenger rememberedSetSize;
cr.
self eek.
"But the system copes with overflow..."
self flag: 'no support for remembered set overflow yet'.
"ok := rootTableOverflowed and: [needGCFlag]"].
scavenger rememberedSetWithIndexDo:
[:obj :i|
(obj bitAnd: self wordSize - 1) ~= 0
ifTrue:
[coInterpreter print: 'misaligned oop in rootTable @ '; printNum: i; print: ' = '; printHex: obj; cr.
self eek.
ok := false]
ifFalse:
[(heapMap heapMapAtWord: (self pointerForOop: obj)) = 0
ifTrue:
[coInterpreter print: 'object leak in remembered set @ '; printNum: i; print: ' = '; printHex: obj; cr.
self eek.
ok := false]
ifFalse:
[(self isYoung: obj) ifTrue:
[coInterpreter print: 'non-root in remembered set @ '; printNum: i; print: ' = '; printHex: obj; cr.
self eek.
ok := false]]]].
self flag: 'no support for remap buffer yet'.
"1 to: remapBufferCount do:
[:ri|
obj := remapBuffer at: ri.
(obj bitAnd: self wordSize - 1) ~= 0
ifTrue:
[coInterpreter print: 'misaligned remapRoot @ '; printNum: ri; print: ' = '; printHex: obj; cr.
self eek.
ok := false]
ifFalse:
[(heapMap heapMapAtWord: (self pointerForOop: obj)) = 0
ifTrue:
[coInterpreter print: 'object leak in remapRoots @ '; printNum: ri; print: ' = '; printHex: obj; cr.
self eek.
ok := false]]]."
self flag: 'no support for extraRoots yet'.
"1 to: extraRootCount do:
[:ri|
obj := (extraRoots at: ri) at: 0.
(obj bitAnd: self wordSize - 1) ~= 0
ifTrue:
[coInterpreter print: 'misaligned extraRoot @ '; printNum: ri; print: ' => '; printHex: obj; cr.
self eek.
ok := false]
ifFalse:
[(heapMap heapMapAtWord: (self pointerForOop: obj)) = 0
ifTrue:
[coInterpreter print: 'object leak in extraRoots @ '; printNum: ri; print: ' => '; printHex: obj; cr.
self eek.
ok := false]]]."
^ok!
Item was added:
+ ----- Method: SpurMemoryManager>>classIndexFieldWidth (in category 'header format') -----
+ classIndexFieldWidth
+ "22-bit class mask => ~ 4M classes"
+ ^22!
Item was changed:
----- Method: SpurMemoryManager>>classTableRootObj: (in category 'accessing') -----
classTableRootObj: anOop
"For mapInterpreterOops"
classTableRootObj := anOop.
+ classTableFirstPage := self fetchPointer: 0 ofObject: classTableRootObj.
+ self assert: (self numSlotsOf: classTableRootObj) = (1 << (self classIndexFieldWidth - self classTableMajorIndexShift)).
+ self assert: (self numSlotsOf: classTableFirstPage) - 1 = self classTableMinorIndexMask!
- classTableFirstPage := self fetchPointer: 0 ofObject: classTableRootObj!
Item was added:
+ ----- Method: SpurMemoryManager>>freeListsObject (in category 'free space') -----
+ freeListsObject
+ ^self objectAfter: trueObj!
Item was changed:
----- Method: SpurMemoryManager>>initialize (in category 'initialization') -----
initialize
"We can put all initializatins that set something to 0 or to false here.
In C all global variables are initialized to 0, and 0 is false."
- freeLists := CArrayAccessor on: (Array new: NumFreeLists withAll: 0).
remapBuffer := Array new: RemapBufferSize.
remapBufferCount := 0.
freeListsMask := totalFreeOldSpace := lowSpaceThreshold := 0.
checkForLeaks := 0.
needGCFlag := signalLowSpace := scavengeInProgress := false.
becomeEffectsFlags := 0.
statScavenges := statIncrGCs := statFullGCs := 0.
statScavengeGCUsecs := statIncrGCUsecs := statFullGCUsecs := 0.
statSGCDeltaUsecs := statIGCDeltaUsecs := statFGCDeltaUsecs := 0.
"We can also initialize here anything that is only for simulation."
heapMap := self wordSize = 4 ifTrue: [CogCheck32BitHeapMap new]!
Item was changed:
----- Method: SpurMemoryManager>>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
memoryLimit
specialObjectsOop
lastHash
"
<inline: false>
+ | freeListObj |
"image may be at a different address; adjust oops for new location"
self adjustAllOopsBy: bytesToShift.
- self initializeOldSpaceFirstFree: freeOldSpaceStart. "initializes endOfMemory, freeStart"
-
specialObjectsOop := specialObjectsOop + bytesToShift.
"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 = newSpaceLimit.
+ self assert: falseObj = (self objectAfter: nilObj).
+ self assert: trueObj = (self objectAfter: falseObj).
+ freeListObj := self objectAfter: trueObj.
+ self assert: (self numSlotsOf: freeListObj) = self numFreeLists.
+ self assert: (self formatOf: freeListObj) = (self wordSize = 4
+ ifTrue: [self firstLongFormat]
+ ifFalse: [self sixtyFourBitIndexableFormat]).
+ freeLists := self firstIndexableField: freeListObj.
+ self classTableRootObj: (self objectAfter: freeListObj).
+
+ self initializeOldSpaceFirstFree: freeOldSpaceStart. "initializes endOfMemory, freeStart"
+
+ "lowSpaceThreshold := 0.
- "rootTableCount := 0.
- rootTableOverflowed := false.
- lowSpaceThreshold := 0.
signalLowSpace := false.
- compStart := 0.
- compEnd := 0.
- fwdTableNext := 0.
- fwdTableLast := 0.
remapBufferCount := 0.
tenuringThreshold := 2000. ""tenure all suriving objects if survivor count is over this threshold""
growHeadroom := 4*1024*1024. ""four megabytes of headroom when growing""
shrinkThreshold := 8*1024*1024. ""eight megabytes 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."!
Item was changed:
----- Method: SpurMemoryManager>>isValidFreeObject: (in category 'free space') -----
isValidFreeObject: objOop
| chunk |
^(self isFreeObject: objOop)
and: [((chunk := (self fetchPointer: self freeChunkNextIndex ofFreeChunk: objOop)) = 0
or: [self isFreeObject: chunk])
+ and: [(self bytesInObject: objOop) / self allocationUnit < self numFreeLists
- and: [(self bytesInObject: objOop) / self allocationUnit < NumFreeLists
or: [((chunk := (self fetchPointer: self freeChunkParentIndex ofFreeChunk: objOop)) = 0
or: [self isFreeObject: chunk])
and: [((chunk := (self fetchPointer: self freeChunkSmallerIndex ofFreeChunk: objOop)) = 0
or: [self isFreeObject: chunk])
and: [(chunk := (self fetchPointer: self freeChunkLargerIndex ofFreeChunk: objOop)) = 0
or: [self isFreeObject: chunk]]]]]]!
Item was changed:
----- Method: SpurMemoryManager>>lowestFreeChunkAssumingSortedFreeSpace (in category 'free space') -----
lowestFreeChunkAssumingSortedFreeSpace
| lowest |
lowest := sortedFreeChunks = 0
ifTrue: [endOfMemory]
ifFalse: [sortedFreeChunks].
+ 1 to: self numFreeLists - 1 do:
- 1 to: NumFreeLists - 1 do:
[:i| | chunk |
chunk := freeLists at: i.
(chunk ~= 0 and: [chunk < lowest]) ifTrue:
[lowest := chunk]].
^lowest!
Item was added:
+ ----- Method: SpurMemoryManager>>numFreeLists (in category 'free space') -----
+ numFreeLists
+ "Answer the number of free lists. We use freeListsMask, a bitmap, to avoid
+ reading empty list heads. This hsould fit in a machine word to end up in a
+ register during free chunk allocation."
+ ^self subclassResponsibility!
Item was changed:
----- Method: SpurMemoryManager>>printFreeChunk: (in category 'debug printing') -----
printFreeChunk: freeChunk
<doNotGenerate>
| numBytes |
numBytes := self bytesInObject: freeChunk.
coInterpreter
print: 'freeChunk '; printHexPtrnp: freeChunk;
print: ' bytes '; printNum: numBytes;
print: ' next '; printHexPtrnp: (self fetchPointer: self freeChunkNextIndex
ofFreeChunk: freeChunk).
+ numBytes / self allocationUnit > self numFreeLists ifTrue:
- numBytes / self allocationUnit > NumFreeLists ifTrue:
[coInterpreter
print: ' ^ '; printHexPtrnp: (self fetchPointer: self freeChunkParentIndex
ofFreeChunk: freeChunk);
print: ' < '; printHexPtrnp: (self fetchPointer: self freeChunkSmallerIndex
ofFreeChunk: freeChunk);
print: ' > '; printHexPtrnp: (self fetchPointer: self freeChunkLargerIndex
ofFreeChunk: freeChunk)].
coInterpreter cr!
Item was added:
+ ----- Method: SpurMemoryManager>>sixtyFourBitLongsClassIndexPun (in category 'class table') -----
+ sixtyFourBitLongsClassIndexPun
+ "Class puns are class indices not used by any class. There may be
+ an entry for the pun that refers to the notional class of objects with
+ this class index. But because the index doesn't match the class it
+ won't show up in allInstances, hence hiding the object with a pun as
+ its class index. The puns occupy indices 16 through 31."
+ ^19!
Item was changed:
----- Method: SpurMemoryManager>>sortFreeSpace (in category 'free space') -----
sortFreeSpace
"Sort free space for best-fit compaction. Sort the individual free lists so that
the lowest address is at the head of each list. Sort the large chunks through the
freeChunkNextAddressIndex from low to high, with the head in sortedFreeChunks."
self checkFreeSpace.
+ 1 to: self numFreeLists - 1 do:
- 1 to: NumFreeLists - 1 do:
[:i| self sortFreeListAt: i].
sortedFreeChunks := 0.
self allObjectsInFreeTree: (freeLists at: 0) do:
[:f| | node prev |
node := sortedFreeChunks.
prev := 0.
[node ~= 0
and: [node < f]] whileTrue:
[prev := node.
node := self fetchPointer: self freeChunkNextAddressIndex ofObject: node].
"insert the node into the sorted list"
self assert: (node = 0 or: [node > f]).
prev = 0
ifTrue:
[sortedFreeChunks := f]
ifFalse:
[self storePointer: self freeChunkNextAddressIndex
ofFreeChunk: prev
withValue: f].
self storePointer: self freeChunkNextAddressIndex
ofFreeChunk: f
withValue: node].
self assert: self sortedFreeChunksAreSorted.
self checkFreeSpace!
Item was added:
+ ----- Method: SpurMemoryManager>>thirtyTwoBitLongsClassIndexPun (in category 'class table') -----
+ thirtyTwoBitLongsClassIndexPun
+ "Class puns are class indices not used by any class. There may be
+ an entry for the pun that refers to the notional class of objects with
+ this class index. But because the index doesn't match the class it
+ won't show up in allInstances, hence hiding the object with a pun as
+ its class index. The puns occupy indices 16 through 31."
+ ^18!
Item was changed:
----- Method: SpurMemoryManager>>totalFreeListBytes (in category 'free space') -----
totalFreeListBytes
| freeBytes bytesInObject obj |
freeBytes := 0.
+ 1 to: self numFreeLists - 1 do:
- 1 to: NumFreeLists - 1 do:
[:i|
bytesInObject := i * self allocationUnit.
obj := freeLists at: i.
[obj ~= 0] whileTrue:
[freeBytes := freeBytes + bytesInObject.
self assert: bytesInObject = (self bytesInObject: obj).
self assert: (self isValidFreeObject: obj).
obj := self fetchPointer: self freeChunkNextIndex ofFreeChunk: obj]].
^freeBytes + (self bytesInFreeTree: (freeLists at: 0))!
1
0