Vm-dev June 2021

vm-dev@lists.squeakfoundation.org

14 participants
74 discussions

VM Maker: VMMaker.oscog-eem.2973.mcz
by commits＠source.squeak.org 23 Jun '21

23 Jun '21

Eliot Miranda uploaded a new version of VMMaker to project VM Maker: http://source.squeak.org/VMMaker/VMMaker.oscog-eem.2973.mcz ==================== Summary ==================== Name: VMMaker.oscog-eem.2973 Author: eem Time: 22 June 2021, 3:35:25.766513 pm UUID: 9066fde9-b924-4276-add0-4727e9c32351 Ancestors: VMMaker.oscog-eem.2972 Oops! The new shorten:toIndexableSize: in SpurMemoryManager needs to be marked <api>. Rename bytesInObject: to bytesInBody: to indicate that it's a heap thang not a Smalltalk thang. =============== Diff against VMMaker.oscog-eem.2972 =============== Item was added: + ----- Method: Spur32BitMemoryManager>>bytesInBody: (in category 'object enumeration') ----- + bytesInBody: objOop + "Answer the total number of bytes in an object including header and possible overflow size header." + <returnTypeC: #usqInt> + | headerNumSlots numSlots | + headerNumSlots := self rawNumSlotsOf: objOop. + numSlots := headerNumSlots = self numSlotsMask + ifTrue: [self rawOverflowSlotsOf: objOop] + ifFalse: [headerNumSlots = 0 ifTrue: [1] ifFalse: [headerNumSlots]]. + ^numSlots + (numSlots bitAnd: 1) << self shiftForWord + + (headerNumSlots = self numSlotsMask + ifTrue: [self baseHeaderSize + self baseHeaderSize] + ifFalse: [self baseHeaderSize])! Item was removed: - ----- Method: Spur32BitMemoryManager>>bytesInObject: (in category 'object enumeration') ----- - bytesInObject: objOop - "Answer the total number of bytes in an object including header and possible overflow size header." - <returnTypeC: #usqInt> - | headerNumSlots numSlots | - headerNumSlots := self rawNumSlotsOf: objOop. - numSlots := headerNumSlots = self numSlotsMask - ifTrue: [self rawOverflowSlotsOf: objOop] - ifFalse: [headerNumSlots = 0 ifTrue: [1] ifFalse: [headerNumSlots]]. - ^numSlots + (numSlots bitAnd: 1) << self shiftForWord - + (headerNumSlots = self numSlotsMask - ifTrue: [self baseHeaderSize + self baseHeaderSize] - ifFalse: [self baseHeaderSize])! Item was changed: ----- Method: Spur32BitMemoryManager>>coalesce:and: (in category 'gc - global') ----- coalesce: obj1 and: obj2 | header1NumSlots header2NumSlots obj2slots newNumSlots | header1NumSlots := self rawNumSlotsOf: obj1. header2NumSlots := self rawNumSlotsOf: obj2. "compute total number of slots in obj2, including header" obj2slots := header2NumSlots = self numSlotsMask ifTrue: [(self rawOverflowSlotsOf: obj2) + (2 * self baseHeaderSize / self wordSize)] ifFalse: [(header2NumSlots = 0 ifTrue: [1] ifFalse: [header2NumSlots]) + (self baseHeaderSize / self wordSize)]. obj2slots := obj2slots + (obj2slots bitAnd: 1). + self assert: obj2slots * self wordSize = (self bytesInBody: obj2). - self assert: obj2slots * self wordSize = (self bytesInObject: obj2). "if obj1 already has a double header things are simple..." header1NumSlots = self numSlotsMask ifTrue: [self rawOverflowSlotsOf: obj1 put: obj2slots + (self rawOverflowSlotsOf: obj1). ^obj1]. "compute total number of slots in obj1, excluding header" header1NumSlots := header1NumSlots = 0 ifTrue: [2] ifFalse: [header1NumSlots + (header1NumSlots bitAnd: 1)]. + self assert: header1NumSlots * self wordSize + self baseHeaderSize = (self bytesInBody: obj1). - self assert: header1NumSlots * self wordSize + self baseHeaderSize = (self bytesInObject: obj1). newNumSlots := obj2slots + header1NumSlots. "if obj1 still only requires a single header things are simple..." newNumSlots < self numSlotsMask ifTrue: [self rawNumSlotsOf: obj1 put: newNumSlots. ^obj1]. "convert from single to double header..." newNumSlots := newNumSlots - (self baseHeaderSize / self wordSize). self longAt: obj1 + self baseHeaderSize put: (self longAt: obj1); longAt: obj1 + 4 + self baseHeaderSize put: ((self longAt: obj1 + 4) bitOr: self numSlotsMask << self numSlotsHalfShift). self longAt: obj1 put: newNumSlots. self longAt: obj1 + 4 put: self numSlotsMask << self numSlotsHalfShift. ^obj1 + self baseHeaderSize! Item was added: + ----- Method: Spur64BitMemoryManager>>bytesInBody: (in category 'object enumeration') ----- + bytesInBody: objOop + "Answer the total number of bytes in an object including header and possible overflow size header." + <returnTypeC: #usqInt> + | header headerNumSlots numSlots | + <var: 'header' type: #usqLong> + self flag: #endianness. + header := self longAt: objOop. + headerNumSlots := header >> self numSlotsFullShift. + numSlots := headerNumSlots = self numSlotsMask + ifTrue: [self rawOverflowSlotsOf: objOop] + ifFalse: [headerNumSlots = 0 ifTrue: [1] ifFalse: [headerNumSlots]]. + ^numSlots << self shiftForWord + + (headerNumSlots = self numSlotsMask + ifTrue: [self baseHeaderSize + self baseHeaderSize] + ifFalse: [self baseHeaderSize])! Item was removed: - ----- Method: Spur64BitMemoryManager>>bytesInObject: (in category 'object enumeration') ----- - bytesInObject: objOop - "Answer the total number of bytes in an object including header and possible overflow size header." - <returnTypeC: #usqInt> - | header headerNumSlots numSlots | - <var: 'header' type: #usqLong> - self flag: #endianness. - header := self longAt: objOop. - headerNumSlots := header >> self numSlotsFullShift. - numSlots := headerNumSlots = self numSlotsMask - ifTrue: [self rawOverflowSlotsOf: objOop] - ifFalse: [headerNumSlots = 0 ifTrue: [1] ifFalse: [headerNumSlots]]. - ^numSlots << self shiftForWord - + (headerNumSlots = self numSlotsMask - ifTrue: [self baseHeaderSize + self baseHeaderSize] - ifFalse: [self baseHeaderSize])! Item was changed: ----- Method: Spur64BitMemoryManager>>coalesce:and: (in category 'gc - global') ----- coalesce: obj1 and: obj2 | header1NumSlots header2NumSlots obj2slots newNumSlots | header1NumSlots := self rawNumSlotsOf: obj1. header2NumSlots := self rawNumSlotsOf: obj2. "compute total number of slots in obj2, including header" obj2slots := header2NumSlots = self numSlotsMask ifTrue: [(self rawOverflowSlotsOf: obj2) + (2 * self baseHeaderSize / self wordSize)] ifFalse: [(header2NumSlots = 0 ifTrue: [1] ifFalse: [header2NumSlots]) + (self baseHeaderSize / self wordSize)]. + self assert: obj2slots * self wordSize = (self bytesInBody: obj2). - self assert: obj2slots * self wordSize = (self bytesInObject: obj2). "if obj1 already has a double header things are simple..." header1NumSlots = self numSlotsMask ifTrue: [self rawOverflowSlotsOf: obj1 put: obj2slots + (self rawOverflowSlotsOf: obj1). ^obj1]. "compute total number of slots in obj1, excluding header" header1NumSlots := header1NumSlots = 0 ifTrue: [1] ifFalse: [header1NumSlots]. + self assert: header1NumSlots * self wordSize + self baseHeaderSize = (self bytesInBody: obj1). - self assert: header1NumSlots * self wordSize + self baseHeaderSize = (self bytesInObject: obj1). newNumSlots := obj2slots + header1NumSlots. "if obj1 still only requires a single header things are simple..." newNumSlots < self numSlotsMask ifTrue: [self rawNumSlotsOf: obj1 put: newNumSlots. ^obj1]. "convert from single to double header..." newNumSlots := newNumSlots - (self baseHeaderSize / self wordSize). self rawNumSlotsOf: obj1 + self baseHeaderSize put: self numSlotsMask; rawOverflowSlotsOf: obj1 + self baseHeaderSize put: newNumSlots. ^obj1 + self baseHeaderSize! Item was changed: ----- Method: SpurGenerationScavenger>>copyAndForward: (in category 'scavenger') ----- copyAndForward: survivor "copyAndForward: survivor copies a survivor object either to futureSurvivorSpace or, if it is to be promoted, to oldSpace. It leaves a forwarding pointer behind. If the object is weak then corpse is threaded onto the weakList for later treatment." <inline: false> | bytesInObj format tenure newLocation | self assert: ((manager isInEden: survivor) "cog methods should be excluded." or: [manager isInPastSpace: survivor]). + bytesInObj := manager bytesInBody: survivor. - bytesInObj := manager bytesInObject: survivor. format := manager formatOf: survivor. tenure := self shouldBeTenured: survivor. "Allow Slang to inline." newLocation := (tenure or: [futureSurvivorStart + bytesInObj > futureSpace limit]) ifTrue: [self copyToOldSpace: survivor bytes: bytesInObj format: format] ifFalse: [self copyToFutureSpace: survivor bytes: bytesInObj]. manager forwardSurvivor: survivor to: newLocation. "if weak or ephemeron add to the relevant list for subsequent scanning." (manager isWeakFormat: format) ifTrue: [self addToWeakList: survivor]. ((manager isEphemeronFormat: format) and: [(self isScavengeSurvivor: (manager keyOfEphemeron: newLocation)) not]) ifTrue: [self addToEphemeronList: survivor]. ^newLocation! Item was changed: ----- Method: SpurGenerationScavenger>>copyAndForwardMourner: (in category 'scavenger') ----- copyAndForwardMourner: mourner "A special version of copyAndForward: for objects in the mournQueue. If we're in the good times tenuring regime then copy to futureSpace, otherwise tenure. Also, don't repeat any of the ephemeron processing." <inline: false> | bytesInObj format tenure newLocation | self assert: ((manager isInEden: mourner) "cog methods should be excluded." or: [manager isInPastSpace: mourner]). + bytesInObj := manager bytesInBody: mourner. - bytesInObj := manager bytesInObject: mourner. format := manager formatOf: mourner. tenure := self shouldMournerBeTenured: mourner. "Allow Slang to inline." newLocation := (tenure or: [futureSurvivorStart + bytesInObj > futureSpace limit]) ifTrue: [self copyToOldSpace: mourner bytes: bytesInObj format: format] ifFalse: [self copyToFutureSpace: mourner bytes: bytesInObj]. manager forwardSurvivor: mourner to: newLocation. "if weak or ephemeron add to the relevant list for subsequent scanning." (manager isWeakFormat: format) ifTrue: [self addToWeakList: mourner]. ^newLocation! Item was changed: ----- Method: SpurMemoryManager>>abandonEmptySegmentForTests (in category 'simulation tests support') ----- abandonEmptySegmentForTests "Assume a freshly-loaded image. Eliminate the last segment." <doNotGenerate> | freeChunk emptySeg | freeChunk := self findLargestFreeChunk. + self assert: totalFreeOldSpace = (self bytesInBody: freeChunk). - self assert: totalFreeOldSpace = (self bytesInObject: freeChunk). self assert: endOfMemory = (self addressAfter: freeChunk). self unlinkSolitaryFreeTreeNode: freeChunk. segmentManager numSegments > 1 ifTrue: + [emptySeg := segmentManager findEmptySegNearestInSizeTo: (self bytesInBody: freeChunk). - [emptySeg := segmentManager findEmptySegNearestInSizeTo: (self bytesInObject: freeChunk). segmentManager removeSegment: emptySeg] ifFalse: [(segmentManager segments at: 0) + segSize: (segmentManager segments at: 0) segSize - (self bytesInBody: freeChunk). - segSize: (segmentManager segments at: 0) segSize - (self bytesInObject: freeChunk). self setLastSegment: (segmentManager segments at: 0); initSegmentBridgeWithBytes: self bridgeSize at: (self startOfObject: freeChunk)]! Item was changed: ----- Method: SpurMemoryManager>>abstractCompaction (in category 'compaction - analysis') ----- abstractCompaction "This method answers a rough estimate of compactibility." <doNotGenerate> | lowestFree freeChunks used movable | lowestFree := SmallInteger maxVal. freeChunks := Set new. used := Set new. movable := Set new. self allObjectsInFreeTreeDo: [:f| (self addressAfter: f) < endOfMemory ifTrue: [freeChunks add: f. f < lowestFree ifTrue: [lowestFree := f]]]. self allOldSpaceObjectsFrom: lowestFree do: [:o| | size delta best | + size := self bytesInBody: o. - size := self bytesInObject: o. delta := SmallInteger maxVal. freeChunks do: [:f| | fs | + ((fs := self bytesInBody: f) >= size) ifTrue: - ((fs := self bytesInObject: f) >= size) ifTrue: [delta > (fs - size) ifTrue: [delta := fs - size. best := f]]]. best ifNotNil: [movable add: o. used add: (freeChunks remove: best)]]. + ^{ totalFreeOldSpace. movable inject: 0 into: [:s :o| s + (self bytesInBody: o)]. used inject: 0 into: [:s :o| s + (self bytesInBody: o)] }! - ^{ totalFreeOldSpace. movable inject: 0 into: [:s :o| s + (self bytesInObject: o)]. used inject: 0 into: [:s :o| s + (self bytesInObject: o)] }! Item was changed: ----- Method: SpurMemoryManager>>addFreeSubTree: (in category 'free space') ----- addFreeSubTree: freeTree "Add a freeChunk sub tree back into the large free chunk tree. This is for allocateOldSpaceChunkOf[Exactly]Bytes:[suchThat:]." | bytesInArg treeNode bytesInNode subNode | "N.B. *can't* use numSlotsOfAny: because of rounding up of odd slots and/or step in size at 1032 bytes in 32-bits or 2048 bytes in 64-bits." self assert: (self isFreeObject: freeTree). + bytesInArg := self bytesInBody: freeTree. - bytesInArg := self bytesInObject: freeTree. self assert: bytesInArg >= (self numFreeLists * self allocationUnit). treeNode := freeLists at: 0. self assert: treeNode ~= 0. + [bytesInNode := self bytesInBody: treeNode. - [bytesInNode := self bytesInObject: treeNode. "check for overlap; could write this as self oop: (self objectAfter: freeChunk) isLessThanOrEqualTo: child... but that relies on headers being correct, etc. So keep it clumsy..." self assert: ((self oop: freeTree + bytesInArg - self baseHeaderSize isLessThanOrEqualTo: treeNode) or: [self oop: freeTree isGreaterThanOrEqualTo: treeNode + bytesInNode - self baseHeaderSize]). self assert: bytesInNode >= (self numFreeLists * self allocationUnit). self assert: bytesInArg ~= bytesInNode. bytesInNode > bytesInArg ifTrue: [subNode := self fetchPointer: self freeChunkSmallerIndex ofFreeChunk: treeNode. subNode = 0 ifTrue: [self storePointer: self freeChunkSmallerIndex ofFreeChunk: treeNode withValue: freeTree. self storePointer: self freeChunkParentIndex ofFreeChunk: freeTree withValue: treeNode. ^self]] ifFalse: [subNode := self fetchPointer: self freeChunkLargerIndex ofFreeChunk: treeNode. subNode = 0 ifTrue: [self storePointer: self freeChunkLargerIndex ofFreeChunk: treeNode withValue: freeTree. self storePointer: self freeChunkParentIndex ofFreeChunk: freeTree withValue: treeNode. ^self]]. treeNode := subNode] repeat! Item was changed: ----- Method: SpurMemoryManager>>addToFreeList:bytes: (in category 'free space') ----- addToFreeList: freeChunk bytes: chunkBytes "Add freeChunk to the relevant freeList. For the benefit of sortedFreeObject:, if freeChunk is large, answer the treeNode it is added to, if it is added to the next list of a freeTreeNode, otherwise answer 0." | index | "coInterpreter transcript ensureCr. coInterpreter print: 'freeing '. self printFreeChunk: freeChunk." self assert: (self isFreeObject: freeChunk). + self assert: chunkBytes = (self bytesInBody: freeChunk). - self assert: chunkBytes = (self bytesInObject: freeChunk). "Too slow to be enabled byt default but useful to debug Selective... self deny: (compactor isSegmentBeingCompacted: (segmentManager segmentContainingObj: freeChunk))." index := chunkBytes / self allocationUnit. index < self numFreeLists ifTrue: [self setNextFreeChunkOf: freeChunk withValue: (freeLists at: index) chunkBytes: chunkBytes. (self isLilliputianSize: chunkBytes) ifFalse: [self storePointer: self freeChunkPrevIndex ofFreeChunk: freeChunk withValue: 0]. freeLists at: index put: freeChunk. freeListsMask := freeListsMask bitOr: 1 << index. ^0]. ^self addToFreeTree: freeChunk bytes: chunkBytes! Item was changed: ----- Method: SpurMemoryManager>>addToFreeTree:bytes: (in category 'free space') ----- addToFreeTree: freeChunk bytes: chunkBytes "Add freeChunk to the large free chunk tree. For the benefit of sortedFreeObject:, answer the treeNode it is added to, if it is added to the next list of a freeTreeNode, otherwise answer 0." | childBytes parent child | self assert: (self isFreeObject: freeChunk). + self assert: chunkBytes = (self bytesInBody: freeChunk). - self assert: chunkBytes = (self bytesInObject: freeChunk). self assert: chunkBytes >= (self numFreeLists * self allocationUnit). self storePointer: self freeChunkNextIndex ofFreeChunk: freeChunk withValue: 0; storePointer: self freeChunkPrevIndex 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 bytesInBody: child. - [childBytes := self bytesInObject: child. "check for overlap; could write this as self oop: (self objectAfter: freeChunk) isLessThanOrEqualTo: child... but that relies on headers being correct, etc. So keep it clumsy..." self assert: ((self oop: freeChunk + chunkBytes - self baseHeaderSize isLessThanOrEqualTo: child) or: [self oop: freeChunk isGreaterThanOrEqualTo: child + childBytes - self baseHeaderSize]). childBytes = chunkBytes ifTrue: "size match; add to list at node." [self setNextFreeChunkOf: freeChunk withValue: (self fetchPointer: self freeChunkNextIndex ofFreeChunk: child) isLilliputianSize: false. self setNextFreeChunkOf: child withValue: freeChunk isLilliputianSize: false. ^child]. "walk down the tree" parent := child. child := self fetchPointer: (childBytes > chunkBytes ifTrue: [self freeChunkSmallerIndex] ifFalse: [self freeChunkLargerIndex]) ofFreeChunk: child]. parent = 0 ifTrue: [self assert: (freeLists at: 0) = 0. freeLists at: 0 put: freeChunk. freeListsMask := freeListsMask bitOr: 1. ^0]. self assert: (freeListsMask anyMask: 1). "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. ^0! Item was changed: ----- Method: SpurMemoryManager>>allInstancesOf: (in category 'primitive support') ----- allInstancesOf: aClass "Attempt to answer an array of all objects, excluding those that may be garbage collected as a side effect of allocating the result array. If no memory is available answer the number of instances as a SmallInteger. Since objects are at least 16 bytes big, and the largest SmallInteger covers 1/4 of the address space, the count can never overflow." | classIndex freeChunk ptr start limit count bytes | classIndex := self rawHashBitsOf: aClass. classIndex = 0 ifTrue: [freeChunk := self allocateSlots: 0 format: self arrayFormat classIndex: ClassArrayCompactIndex. ^freeChunk]. MarkObjectsForEnumerationPrimitives ifTrue: [self markObjects: true]. "may not want to revive objects unnecessarily; but marking is sloooow." freeChunk := self allocateLargestFreeChunk. "N.B. Does /not/ update totalFreeOldSpace" start := freeChunk + self baseHeaderSize. limit := self addressAfter: freeChunk. (self isClassAtUniqueIndex: aClass) ifTrue: [self uniqueIndex: classIndex allInstancesInto: start limit: limit resultsInto: [:c :p| count := c. ptr := p]] ifFalse: [self ambiguousClass: aClass allInstancesInto: start limit: limit resultsInto: [:c :p| count := c. ptr := p]]. self assert: (self isEmptyObjStack: markStack). MarkObjectsForEnumerationPrimitives ifTrue: [self assert: self allObjectsUnmarked. self emptyObjStack: weaklingStack] ifFalse: [self assert: (self isEmptyObjStack: weaklingStack)]. (count > (ptr - start / self bytesPerOop) "not enough room" or: [limit ~= ptr and: [limit - ptr <= self allocationUnit]]) ifTrue: "can't split a single word" [self freeObject: freeChunk. ^self integerObjectOf: count]. count < self numSlotsMask ifTrue: [| smallObj | smallObj := self allocateSlots: count format: self arrayFormat classIndex: ClassArrayCompactIndex. 0 to: count - 1 do: [:i| self storePointerUnchecked: i ofObject: smallObj withValue: (self fetchPointer: i ofFreeChunk: freeChunk)]. + self freeChunkWithBytes: (self bytesInBody: freeChunk) at: (self startOfObject: freeChunk). - self freeChunkWithBytes: (self bytesInObject: freeChunk) at: (self startOfObject: freeChunk). self beRootIfOld: smallObj. self checkFreeSpace: GCModeFull. ^smallObj]. bytes := self largeObjectBytesForSlots: count. start := self startOfObject: freeChunk. self freeChunkWithBytes: limit - start - bytes at: start + bytes. totalFreeOldSpace := totalFreeOldSpace - bytes. self rawOverflowSlotsOf: freeChunk put: count. self set: freeChunk classIndexTo: ClassArrayCompactIndex formatTo: self arrayFormat. self possibleRootStoreInto: freeChunk. self checkFreeSpace: GCModeFull. self runLeakCheckerFor: GCModeFull. + ^freeChunk! - ^freeChunk - - ! Item was changed: ----- Method: SpurMemoryManager>>allObjects (in category 'primitive support') ----- allObjects "Attempt to answer an array of all objects, excluding those that may be garbage collected as a side effect of allocating the result array. If no memory is available answer the number of objects as a SmallInteger. Since objects are at least 16 bytes big, and the largest SmallInteger covers 1/4 of the address space, the count can never overflow." | freeChunk ptr start limit count bytes | MarkObjectsForEnumerationPrimitives ifTrue: [self markObjects: true]. "may not want to revive objects unnecessarily; but marking is sloooow." freeChunk := self allocateLargestFreeChunk. "N.B. Does /not/ update totalFreeOldSpace" ptr := start := freeChunk + self baseHeaderSize. limit := self addressAfter: freeChunk. count := 0. self allHeapEntitiesDo: [:obj| "continue enumerating even if no room so as to unmark all objects." (MarkObjectsForEnumerationPrimitives ifTrue: [self isMarked: obj] ifFalse: [true]) ifTrue: [(self isNormalObject: obj) ifTrue: [MarkObjectsForEnumerationPrimitives ifTrue: [self setIsMarkedOf: obj to: false]. count := count + 1. ptr < limit ifTrue: [self longAt: ptr put: obj. ptr := ptr + self bytesPerOop]] ifFalse: [MarkObjectsForEnumerationPrimitives ifTrue: [(self isSegmentBridge: obj) ifFalse: [self setIsMarkedOf: obj to: false]]]]]. self assert: (self isEmptyObjStack: markStack). MarkObjectsForEnumerationPrimitives ifTrue: [self assert: self allObjectsUnmarked. self emptyObjStack: weaklingStack] ifFalse: [self assert: (self isEmptyObjStack: weaklingStack)]. self assert: count >= self numSlotsMask. (count > (ptr - start / self bytesPerOop) "not enough room" or: [limit ~= ptr and: [limit - ptr <= self allocationUnit]]) ifTrue: "can't split a single word" + [self freeChunkWithBytes: (self bytesInBody: freeChunk) at: (self startOfObject: freeChunk). - [self freeChunkWithBytes: (self bytesInObject: freeChunk) at: (self startOfObject: freeChunk). self checkFreeSpace: GCModeFull. ^self integerObjectOf: count]. bytes := self largeObjectBytesForSlots: count. start := self startOfObject: freeChunk. self freeChunkWithBytes: limit - start - bytes at: start + bytes. totalFreeOldSpace := totalFreeOldSpace - bytes. self rawOverflowSlotsOf: freeChunk put: count. self set: freeChunk classIndexTo: ClassArrayCompactIndex formatTo: self arrayFormat. self possibleRootStoreInto: freeChunk. self checkFreeSpace: GCModeFull. self runLeakCheckerFor: GCModeFull. + ^freeChunk! - ^freeChunk - - ! Item was changed: ----- Method: SpurMemoryManager>>allocateLargestFreeChunk (in category 'free space') ----- allocateLargestFreeChunk "Answer the largest free chunk in the free lists." <inline: false> | freeChunk next | "would like to use ifNotNil: but the ^next inside the ^blah ifNotNil: confused Slang" freeChunk := self findLargestFreeChunk. freeChunk ifNil: [^nil]. "This will be the node, not a list element. Answer a list element in preference." next := self fetchPointer: self freeChunkNextIndex ofFreeChunk: freeChunk. next ~= 0 ifTrue: + [self assert: (self bytesInBody: freeChunk) >= self numFreeLists. "findLargestFreeChunk searches only the tree" - [self assert: (self bytesInObject: freeChunk) >= self numFreeLists. "findLargestFreeChunk searches only the tree" self setNextFreeChunkOf: freeChunk withValue: (self fetchPointer: self freeChunkNextIndex ofFreeChunk: next) isLilliputianSize: false. ^next]. self unlinkSolitaryFreeTreeNode: freeChunk. ^freeChunk! 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." <var: #chunkBytes type: #usqInt> | initialIndex chunk index nodeBytes parent child | "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: [(freeListsMask anyMask: 1 << initialIndex) ifTrue: [(chunk := freeLists at: initialIndex) ~= 0 ifTrue: [self assert: chunk = (self startOfObject: chunk). self assertValidFreeObject: chunk. self unlinkFreeChunk: chunk atIndex: initialIndex chunkBytes: chunkBytes. ^ chunk]. freeListsMask := freeListsMask - (1 << initialIndex)]. "first search for free chunks of a multiple of chunkBytes in size" index := initialIndex. [(index := index + index) < self numFreeLists and: [1 << index <= freeListsMask]] whileTrue: [(freeListsMask anyMask: 1 << index) ifTrue: [(chunk := freeLists at: index) ~= 0 ifTrue: [self assert: chunk = (self startOfObject: chunk). self assertValidFreeObject: chunk. self unlinkFreeChunk: chunk atIndex: index isLilliputianSize: false. + self assert: (self bytesInBody: chunk) = (index * self allocationUnit). - self assert: (self bytesInObject: chunk) = (index * self allocationUnit). self freeChunkWithBytes: index * self allocationUnit - chunkBytes at: (self startOfObject: chunk) + chunkBytes. ^chunk]. freeListsMask := freeListsMask - (1 << index)]]. "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 and: [1 << index <= freeListsMask]] whileTrue: [(freeListsMask anyMask: 1 << index) ifTrue: [(chunk := freeLists at: index) ~= 0 ifTrue: [self assert: chunk = (self startOfObject: chunk). self assertValidFreeObject: chunk. self unlinkFreeChunk: chunk atIndex: index isLilliputianSize: false. + self assert: (self bytesInBody: chunk) = (index * self allocationUnit). - 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 assertValidFreeObject: child. + childBytes := self bytesInBody: 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 assertValidFreeObject: chunk. self setNextFreeChunkOf: child withValue: (self fetchPointer: self freeChunkNextIndex ofFreeChunk: chunk) isLilliputianSize: false. ^self startOfObject: chunk]. nodeBytes := childBytes. parent := child. 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" ^nil]. "self printFreeChunk: parent" self assert: (nodeBytes = chunkBytes or: [nodeBytes >= (chunkBytes + (2 * self allocationUnit))]). + self assert: (self bytesInBody: parent) = nodeBytes. - 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 setNextFreeChunkOf: parent withValue: (self fetchPointer: self freeChunkNextIndex ofFreeChunk: chunk) isLilliputianSize: false. chunkBytes ~= nodeBytes ifTrue: [self freeChunkWithBytes: nodeBytes - chunkBytes at: (self startOfObject: chunk) + chunkBytes]. ^self startOfObject: chunk]. "no list; remove the interior node" chunk := parent. self unlinkSolitaryFreeTreeNode: chunk. "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>>allocateOldSpaceChunkOfBytes:suchThat: (in category 'free space') ----- allocateOldSpaceChunkOfBytes: chunkBytes suchThat: acceptanceBlock "Answer a chunk of oldSpace from the free lists that satisfies acceptanceBlock, if available, otherwise answer nil. Break up a larger chunk if one of the exact size cannot be found. N.B. the chunk is simply a pointer, it has no valid header. The caller *must* fill in the header correctly." <var: #chunkBytes type: #usqInt> | initialIndex node next prev index child childBytes acceptedChunk acceptedNode | <inline: true> "must inline for acceptanceBlock" "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: [(freeListsMask anyMask: 1 << initialIndex) ifTrue: [(node := freeLists at: initialIndex) = 0 ifTrue: [freeListsMask := freeListsMask - (1 << initialIndex)] ifFalse: [prev := 0. [node ~= 0] whileTrue: [self assert: node = (self startOfObject: node). self assertValidFreeObject: node. next := self fetchPointer: self freeChunkNextIndex ofFreeChunk: node. (acceptanceBlock value: node) ifTrue: [prev = 0 ifTrue: [self unlinkFreeChunk: node atIndex: initialIndex chunkBytes: chunkBytes] ifFalse: [self setNextFreeChunkOf: prev withValue: next chunkBytes: chunkBytes]. ^node]. prev := node. node := next]]]. "first search for free chunks of a multiple of chunkBytes in size" index := initialIndex. [(index := index + initialIndex) < self numFreeLists and: [1 << index <= freeListsMask]] whileTrue: [(freeListsMask anyMask: 1 << index) ifTrue: [(node := freeLists at: index) = 0 ifTrue: [freeListsMask := freeListsMask - (1 << index)] ifFalse: [prev := 0. [node ~= 0] whileTrue: [self assert: node = (self startOfObject: node). self assertValidFreeObject: node. next := self fetchPointer: self freeChunkNextIndex ofFreeChunk: node. (acceptanceBlock value: node) ifTrue: [prev = 0 ifTrue: [self unlinkFreeChunk: node atIndex: index isLilliputianSize: false.] ifFalse: [self setNextFreeChunkOf: prev withValue: next isLilliputianSize: false.]. self freeChunkWithBytes: index * self allocationUnit - chunkBytes at: (self startOfObject: node) + chunkBytes. ^node]. prev := node. node := next]]]]. "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 and: [1 << index <= freeListsMask]] whileTrue: [(freeListsMask anyMask: 1 << index) ifTrue: [(node := freeLists at: index) = 0 ifTrue: [freeListsMask := freeListsMask - (1 << index)] ifFalse: [prev := 0. [node ~= 0] whileTrue: [self assert: node = (self startOfObject: node). self assertValidFreeObject: node. next := self fetchPointer: self freeChunkNextIndex ofFreeChunk: node. (acceptanceBlock value: node) ifTrue: [prev = 0 ifTrue: [self unlinkFreeChunk: node atIndex: index isLilliputianSize: false.] ifFalse: [self setNextFreeChunkOf: prev withValue: next isLilliputianSize: false.]. self freeChunkWithBytes: index * self allocationUnit - chunkBytes at: (self startOfObject: node) + chunkBytes. ^node]. prev := node. node := next]]]]]. "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. acceptedChunk and acceptedNode save us from having to back-up when the acceptanceBlock filters-out all nodes of the right size, but there are nodes of the wrong size it does accept." child := freeLists at: 0. node := acceptedChunk := acceptedNode := 0. [child ~= 0] whileTrue: [ self assertValidFreeObject: child. + childBytes := self bytesInBody: child. - childBytes := self bytesInObject: child. childBytes = chunkBytes ifTrue: "size match; try to remove from list at node." [node := child. [prev := node. node := self fetchPointer: self freeChunkNextIndex ofFreeChunk: node. node ~= 0] whileTrue: [(acceptanceBlock value: node) ifTrue: [self assertValidFreeObject: node. self setNextFreeChunkOf: prev withValue: (self fetchPointer: self freeChunkNextIndex ofFreeChunk: node) isLilliputianSize: false. ^self startOfObject: node]]. (acceptanceBlock value: child) ifTrue: [next := self fetchPointer: self freeChunkNextIndex ofFreeChunk: child. next = 0 ifTrue: "no list; remove the interior node" [self unlinkSolitaryFreeTreeNode: child] ifFalse: "list; replace node with it" [self inFreeTreeReplace: child with: next]. ^self startOfObject: child]]. child ~= 0 ifTrue: ["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: [self flag: 'we can do better here; preferentially choosing the lowest node. That would be a form of best-fit since we are trying to compact down'. node := child. child := self fetchPointer: self freeChunkSmallerIndex ofFreeChunk: node. acceptedNode = 0 ifTrue: [acceptedChunk := node. "first search the list." [acceptedChunk := self fetchPointer: self freeChunkNextIndex ofFreeChunk: acceptedChunk. (acceptedChunk ~= 0 and: [acceptanceBlock value: acceptedChunk]) ifTrue: [acceptedNode := node]. acceptedChunk ~= 0 and: [acceptedNode = 0]] whileTrue. "nothing on the list; will the node do? This prefers acceptable nodes higher up the tree over acceptable list elements further down, but we haven't got all day..." (acceptedNode = 0 and: [acceptanceBlock value: node]) ifTrue: [acceptedNode := node. child := 0 "break out of loop now we have an acceptedNode"]]]]]. acceptedNode ~= 0 ifTrue: [acceptedChunk ~= 0 ifTrue: + [self assert: (self bytesInBody: acceptedChunk) >= (chunkBytes + self allocationUnit). - [self assert: (self bytesInObject: acceptedChunk) >= (chunkBytes + self allocationUnit). [next := self fetchPointer: self freeChunkNextIndex ofFreeChunk: acceptedNode. next ~= acceptedChunk] whileTrue: [acceptedNode := next]. self setNextFreeChunkOf: acceptedNode withValue: (self fetchPointer: self freeChunkNextIndex ofFreeChunk: acceptedChunk) isLilliputianSize: false. + self freeChunkWithBytes: (self bytesInBody: acceptedChunk) - chunkBytes - self freeChunkWithBytes: (self bytesInObject: acceptedChunk) - chunkBytes at: (self startOfObject: acceptedChunk) + chunkBytes. ^self startOfObject: acceptedChunk]. next := self fetchPointer: self freeChunkNextIndex ofFreeChunk: acceptedNode. next = 0 ifTrue: "no list; remove the interior node" [self unlinkSolitaryFreeTreeNode: acceptedNode] ifFalse: "list; replace node with it" [self inFreeTreeReplace: acceptedNode with: next]. + self assert: (self bytesInBody: acceptedNode) >= (chunkBytes + self allocationUnit). + self freeChunkWithBytes: (self bytesInBody: acceptedNode) - chunkBytes - self assert: (self bytesInObject: acceptedNode) >= (chunkBytes + self allocationUnit). - self freeChunkWithBytes: (self bytesInObject: acceptedNode) - chunkBytes at: (self startOfObject: acceptedNode) + chunkBytes. ^self startOfObject: acceptedNode]. totalFreeOldSpace := totalFreeOldSpace + chunkBytes. "optimism was unfounded" ^nil! Item was changed: ----- Method: SpurMemoryManager>>assertInnerValidFreeObject: (in category 'free space') ----- assertInnerValidFreeObject: objOop <inline: #never> "we don't want to inline so we can nest that in an assertion with the return true so the production VM does not generate any code here, while in simulation, the code breaks on the assertion we want to." | chunk index | self assert: (self oop: (self addressAfter: objOop) isLessThanOrEqualTo: endOfMemory). chunk := self fetchPointer: self freeChunkNextIndex ofFreeChunk: objOop. self assert: (chunk = 0 or: [self isFreeOop: chunk]). + (self isLilliputianSize: (self bytesInBody: objOop)) ifFalse: - (self isLilliputianSize: (self bytesInObject: objOop)) ifFalse: ["double linkedlist assertions" chunk := self fetchPointer: self freeChunkNextIndex ofFreeChunk: objOop. chunk = 0 ifFalse: [self assert: (self isFreeOop: chunk). self assert: objOop = (self fetchPointer: self freeChunkPrevIndex ofFreeChunk: chunk)]. chunk := self fetchPointer: self freeChunkPrevIndex ofFreeChunk: objOop. + index := (self bytesInBody: objOop) / self allocationUnit. - index := (self bytesInObject: objOop) / self allocationUnit. (index < self numFreeLists and: [1 << index <= freeListsMask]) ifTrue: [(freeLists at: index) = objOop ifTrue: [self assert: chunk = 0]] ifFalse: [self freeTreeNodesDo: [:freeNode | freeNode = objOop ifTrue: [self assert: chunk = 0]. freeNode]]. chunk = 0 ifFalse: [self assert: (self isFreeOop: chunk). self assert: objOop = (self fetchPointer: self freeChunkNextIndex ofFreeChunk: chunk)]]. (self isLargeFreeObject: objOop) ifTrue: ["Tree assertions" chunk := self fetchPointer: self freeChunkParentIndex ofFreeChunk: objOop. self assert: (chunk = 0 or: [(self isFreeOop: chunk) and: [self isLargeFreeObject: chunk]]). chunk := self fetchPointer: self freeChunkSmallerIndex ofFreeChunk: objOop. self assert: (chunk = 0 or: [(self isFreeOop: chunk) and: [self isLargeFreeObject: chunk]]). chunk := self fetchPointer: self freeChunkLargerIndex ofFreeChunk: objOop. self assert: (chunk = 0 or: [(self isFreeOop: chunk) and: [self isLargeFreeObject: chunk]])]. ^ true! Item was changed: ----- Method: SpurMemoryManager>>biggies (in category 'compaction - analysis') ----- biggies "This method answers a sorted collection of the objects >= 1,000,000 bytes long, above the lowest large free chunk, sandwiched between nilObj and the end of memory." <doNotGenerate> | lowestFree biggies | lowestFree := SmallInteger maxVal. self allObjectsInFreeTreeDo: [:f| (self addressAfter: f) < endOfMemory ifTrue: [f < lowestFree ifTrue: [lowestFree := f]]]. biggies := SortedCollection new. self allOldSpaceObjectsFrom: lowestFree do: [:f| + (self bytesInBody: f) >= 1000000 ifTrue: - (self bytesInObject: f) >= 1000000 ifTrue: [biggies add: f]]. + ^{{nilObj hex. #nil}}, (biggies collect: [:f| {f hex. self bytesInBody: f}]), {{endOfMemory hex. #endOfMemory}}! - ^{{nilObj hex. #nil}}, (biggies collect: [:f| {f hex. self bytesInObject: f}]), {{endOfMemory hex. #endOfMemory}}! Item was added: + ----- Method: SpurMemoryManager>>bytesInBody: (in category 'object enumeration') ----- + bytesInBody: objOop + "Answer the total number of bytes in an object including header and possible overflow size header." + self subclassResponsibility! Item was removed: - ----- Method: SpurMemoryManager>>bytesInObject: (in category 'object enumeration') ----- - bytesInObject: objOop - "Answer the total number of bytes in an object including header and possible overflow size header." - self subclassResponsibility! Item was changed: ----- Method: SpurMemoryManager>>checkForCompactableObjects (in category 'debug support') ----- checkForCompactableObjects "self checkForCompactableObjects" <doNotGenerate> | firstFree them sizes | firstFree := 0. self allOldSpaceEntitiesDo: [:o| (firstFree = 0 and: [self isFreeObject: o]) ifTrue: [firstFree := o]]. firstFree = 0 ifTrue: [^nil]. sizes := Bag new. self allFreeObjectsDo: + [:f| sizes add: (self bytesInBody: f)]. - [:f| sizes add: (self bytesInObject: f)]. them := OrderedCollection new. self allOldSpaceObjectsFrom: firstFree do: [:o| | b | + b := self bytesInBody: o. - b := self bytesInObject: o. (sizes includes: b) ifTrue: [them add: o. sizes remove: b]]. ^them isEmpty ifFalse: [{them size. them first. them last}]! Item was changed: ----- Method: SpurMemoryManager>>checkHeapFreeSpaceIntegrity (in category 'debug support') ----- checkHeapFreeSpaceIntegrity "Perform an integrity/leak check using the heapMap. Assume clearLeakMapAndMapAccessibleFreeSpace has set a bit at each free chunk's header. Scan all objects in the heap checking that no pointer points to a free chunk and that all free chunks that refer to others refer to marked chunks. Answer if all checks pass." | ok total | <inline: false> <var: 'total' type: #usqInt> ok := true. total := 0. 0 to: self numFreeLists - 1 do: [:i| (freeLists at: i) ~= 0 ifTrue: [(heapMap heapMapAtWord: (self pointerForOop: (freeLists at: i))) = 0 ifTrue: [coInterpreter print: 'leak in free list '; printNum: i; print: ' to non-free '; printHex: (freeLists at: i); cr. self eek. ok := false]]]. "Excuse the duplication but performance is at a premium and we avoid some tests by splitting the newSpace and oldSpace enumerations." self allNewSpaceEntitiesDo: [:obj| | fieldOop | (self isFreeObject: obj) ifTrue: [coInterpreter print: 'young object '; printHex: obj; print: ' is free'; cr. self eek. ok := false] ifFalse: [obj ~= freeSpaceCheckOopToIgnore ifTrue: [0 to: (self numPointerSlotsOf: obj) - 1 do: [:fi| fieldOop := self fetchPointer: fi ofObject: obj. (self isNonImmediate: fieldOop) ifTrue: [(heapMap heapMapAtWord: (self pointerForOop: fieldOop)) ~= 0 ifTrue: [coInterpreter print: 'object leak in '; printHex: obj; print: ' @ '; printNum: fi; print: ' = '; printHex: fieldOop; print: ' is free'; cr. self eek. ok := false]]]]]]. self allOldSpaceEntitiesDo: [:obj| | fieldOop | (self isFreeObject: obj) ifTrue: [(heapMap heapMapAtWord: (self pointerForOop: obj)) = 0 ifTrue: [coInterpreter print: 'leak in free chunk '; printHex: obj; print: ' is unmapped?!! '; cr. self eek. ok := false]. fieldOop := self fetchPointer: self freeChunkNextIndex ofFreeChunk: obj. (fieldOop ~= 0 and: [(heapMap heapMapAtWord: (self pointerForOop: fieldOop)) = 0]) ifTrue: [coInterpreter print: 'leak in free chunk '; printHex: obj; print: ' @ 0 = '; printHex: fieldOop; print: ' is unmapped'; cr. self eek. ok := false]. + (self isLilliputianSize: (self bytesInBody: obj)) ifFalse: - (self isLilliputianSize: (self bytesInObject: obj)) ifFalse: [fieldOop := self fetchPointer: self freeChunkPrevIndex ofFreeChunk: obj. (fieldOop ~= 0 and: [(heapMap heapMapAtWord: (self pointerForOop: fieldOop)) = 0]) ifTrue: [coInterpreter print: 'leak in free chunk '; printHex: obj; print: ' @ 0 = '; printHex: fieldOop; print: ' is unmapped'; cr. self eek. ok := false]]. (self isLargeFreeObject: obj) ifTrue: [self freeChunkParentIndex to: self freeChunkLargerIndex do: [:fi| fieldOop := self fetchPointer: fi ofFreeChunk: obj. (fieldOop ~= 0 and: [(heapMap heapMapAtWord: (self pointerForOop: fieldOop)) = 0]) ifTrue: [coInterpreter print: 'leak in free chunk '; printHex: obj; print: ' @ '; printNum: fi; print: ' = '; printHex: fieldOop; print: ' is unmapped'; cr. self eek. ok := false]]]. + total := total + (self bytesInBody: obj)] - total := total + (self bytesInObject: obj)] ifFalse: [obj ~= freeSpaceCheckOopToIgnore ifTrue: [0 to: (self numPointerSlotsOf: obj) - 1 do: [:fi| (self isForwarded: obj) ifTrue: [self assert: fi = 0. "I'm now trying to use forwarders in GC algorithms..." fieldOop := self fetchPointer: fi ofMaybeForwardedObject: obj] ifFalse: "We keep #fetchPointer:ofObject: API here for assertions" [fieldOop := self fetchPointer: fi ofObject: obj]. (self isNonImmediate: fieldOop) ifTrue: [(heapMap heapMapAtWord: (self pointerForOop: fieldOop)) ~= 0 ifTrue: [coInterpreter print: 'object leak in '; printHex: obj; print: ' @ '; printNum: fi; print: ' = '; printHex: fieldOop; print: ' is free'; cr. self eek. ok := false]]]]]]. total ~= totalFreeOldSpace ifTrue: [coInterpreter print: 'incorrect totalFreeOldSpace; expected '; printNum: totalFreeOldSpace; print: ' found '; printNum: total; cr. self eek. ok := false]. ^ok! Item was changed: ----- Method: SpurMemoryManager>>checkHeapIntegrity:classIndicesShouldBeValid: (in category 'debug support') ----- (excessive size, no diff calculated) Item was changed: ----- Method: SpurMemoryManager>>containsOnlyValidBecomeObjects:and:twoWay:copyHash: (in category 'become implementation') ----- containsOnlyValidBecomeObjects: array1 and: array2 twoWay: isTwoWay copyHash: copyHash "Answer 0 if neither array contains an object inappropriate for the become operation. Otherwise answer an informative error code for the first offending object found: Can't become: immediates => PrimErrInappropriate Shouldn't become pinned objects => PrimErrObjectIsPinned. Shouldn't become immutable objects => PrimErrNoModification. Can't copy hash into immediates => PrimErrInappropriate. Two-way become may require memory to create copies => PrimErrNoMemory. As a side-effect unforward any forwarders in the two arrays if answering 0." <inline: true> | fieldOffset effectsFlags oop1 oop2 size | fieldOffset := self lastPointerOf: array1. effectsFlags := size := 0. "array1 is known to be the same size as array2" [fieldOffset >= self baseHeaderSize] whileTrue: [oop1 := self longAt: array1 + fieldOffset. (self isOopForwarded: oop1) ifTrue: [oop1 := self followForwarded: oop1. self longAt: array1 + fieldOffset put: oop1]. self ifOopInvalidForBecome: oop1 errorCodeInto: [:errCode| ^errCode]. oop2 := self longAt: array2 + fieldOffset. (self isOopForwarded: oop2) ifTrue: [oop2 := self followForwarded: oop2. self longAt: array2 + fieldOffset put: oop2]. oop1 ~= oop2 ifTrue: [isTwoWay ifTrue: [self ifOopInvalidForBecome: oop2 errorCodeInto: [:errCode| ^errCode]. + size := size + (self bytesInBody: oop1) + (self bytesInBody: oop2). - size := size + (self bytesInObject: oop1) + (self bytesInObject: oop2). effectsFlags := (effectsFlags bitOr: (self becomeEffectFlagsFor: oop1)) bitOr: (self becomeEffectFlagsFor: oop2)] ifFalse: [copyHash ifTrue: [(self isImmediate: oop2) ifTrue: [^PrimErrInappropriate]. (self isObjImmutable: oop2) ifTrue: [^PrimErrNoModification]]. effectsFlags := effectsFlags bitOr: (self becomeEffectFlagsFor: oop1)]]. fieldOffset := fieldOffset - self bytesPerOop]. size >= (totalFreeOldSpace + (scavengeThreshold - freeStart)) ifTrue: [^PrimErrNoMemory]. "only set flags after checking all args." becomeEffectsFlags := effectsFlags. ^0! Item was changed: ----- Method: SpurMemoryManager>>copyObj:toAddr:stopAt:savedFirstFields:index: (in category 'image segment in/out') ----- copyObj: objOop toAddr: segAddr stopAt: endSeg savedFirstFields: savedFirstFields index: i "This is part of storeImageSegmentInto:outPointers:roots:. Copy objOop into the segment beginning at segAddr, and forward it to the copy, saving its first field in savedFirstField, and setting its marked bit to indicate it has been copied. If it is a class in the class table, set the copy's hash to 0 for reassignment on load, and mark it as a class by setting its isRemembered bit. Answer the next segmentAddr if successful. Answer an appropriate error code if not" "Copy the object..." | bodySize copy hash | <inline: false> self deny: (self isCopiedIntoSegment: objOop). + bodySize := self bytesInBody: objOop. - bodySize := self bytesInObject: objOop. (self oop: segAddr + bodySize isGreaterThanOrEqualTo: endSeg) ifTrue: [^PrimErrWritePastObject halt]. self memcpy: segAddr asVoidPointer _: (self startOfObject: objOop) asVoidPointer _: bodySize. copy := self objectStartingAt: segAddr. "Clear remembered, mark bits of all headers copied into the segment (except classes)" self setIsRememberedOf: copy to: false; setIsMarkedOf: copy to: false. "Make any objects with hidden dynamic state (contexts, methods) look like normal objects." self ifAProxy: objOop updateCopy: copy. "If the object is a class, zero its identityHash (which is its classIndex) and set its isRemembered bit. It will be assigned a new hash and entered into the table on load." hash := self rawHashBitsOf: objOop. (hash > self lastClassIndexPun and: [(self classOrNilAtIndex: hash) = objOop]) ifTrue: [self setHashBitsOf: copy to: 0. self setIsRememberedOf: copy to: true]. "Now forward the object to its copy in the segment." self storePointerUnchecked: i ofObject: savedFirstFields withValue: (self fetchPointer: 0 ofObject: objOop); storePointerUnchecked: 0 ofObject: objOop withValue: copy; markAsCopiedIntoSegment: objOop. "Answer the new end of segment" ^segAddr + bodySize! Item was changed: ----- Method: SpurMemoryManager>>detachFreeObject: (in category 'free space') ----- detachFreeObject: freeChunk <inline: true> | chunkBytes | + chunkBytes := self bytesInBody: freeChunk. - chunkBytes := self bytesInObject: freeChunk. totalFreeOldSpace := totalFreeOldSpace - chunkBytes. self unlinkFreeChunk: freeChunk chunkBytes: chunkBytes! Item was changed: ----- Method: SpurMemoryManager>>doShorten:toIndexableSize: (in category 'indexing primitive support') ----- doShorten: objOop toIndexableSize: indexableSize "Reduce the number of indexable fields in objOop, a pointer object, to nSlots. Convert the unused residual to a free chunk. Without changes to numSlotsForShortening:toIndexableSize: this only works for arrayFormat and longFormat objects. Answer the number of bytes returned to free memory, which may be zero if no change was possible." <inline: false> <api> | followingAddress numSlots bytesBefore delta copy freeChunk | followingAddress := self addressAfter: objOop. "for assert checking" self assert: (self oop: followingAddress isLessThanOrEqualTo: endOfMemory). numSlots := self numSlotsForShortening: objOop toIndexableSize: indexableSize. + bytesBefore := self bytesInBody: objOop. - bytesBefore := self bytesInObject: objOop. delta := bytesBefore - (self objectBytesForSlots: numSlots). "Since the system rounds objects up to 64-bits, losing a 32-bit slot may not actually change the bytes occupied by the object." delta = 0 ifTrue: [(self hasOverflowHeader: objOop) ifTrue: [self rawOverflowSlotsOf: objOop put: numSlots] ifFalse: [self rawNumSlotsOf: objOop put: numSlots]. self updateFormatOfShortenedObject: objOop to: indexableSize. ^0]. "Currently we can't have one word gaps in oldSpace but we can in newSpace. So only create a copy and forward if objOop is in old space. If in newSpace we'll create a slimbridge below." (delta <= self allocationUnit and: [self isOldObject: objOop]) ifTrue: [| format | format := self normalisedFormatFor: objOop indexableSize: indexableSize. copy := self allocateSlots: numSlots format: format classIndex: (self classIndexOf: objOop). copy ifNil: [self error: 'shorten:toIndexableSize: attempted to shorten by allocationUnit and failed to allocate space for copy!!']. (self isPureBitsFormat: format) ifTrue: [self memcpy: (self firstIndexableField: copy) _: (self firstIndexableField: objOop) _: (self numBytesOfBits: copy format: format)] ifFalse: [0 to: numSlots - 1 do: [:i| self storePointerUnchecked: i ofObject: copy withValue: (self fetchPointer: i ofObject: objOop)]]. (self isRemembered: objOop) ifTrue: [scavenger remember: copy]. self forward: objOop to: copy. ^0]. (self hasOverflowHeader: objOop) ifTrue: [self rawOverflowSlotsOf: objOop put: numSlots. "Setting an overflow slot count to 0 or 1 in newSpace creates a slimbridge. So we must also change the normal slot count so that the object no longer has the overflow header word, which has become the slimbridge." numSlots <= 1 ifTrue: [(self oop: objOop isLessThan: oldSpaceStart) ifTrue: [self rawNumSlotsOf: objOop put: numSlots. self hackSlimBridgeTo: objOop at: objOop - self allocationUnit]]] ifFalse: [self assert: numSlots < self numSlotsMask. self rawNumSlotsOf: objOop put: numSlots]. "{self addressAfter: objOop. delta. (self addressAfter: objOop) + delta. followingAddress} collect: #hex" delta := followingAddress - (self addressAfter: objOop). self assert: (delta >= self allocationUnit and: [delta \\ self allocationUnit = 0]). delta = self allocationUnit ifTrue: [self deny: (self isOldObject: objOop). delta := 0. followingAddress = freeStart ifTrue: [freeStart := self addressAfter: objOop] ifFalse: [self hackSlimBridgeTo: followingAddress at: (self addressAfter: objOop)]] ifFalse: [freeChunk := self initFreeChunkWithBytes: delta at: (self addressAfter: objOop). self assert: (self objectAfter: objOop) = freeChunk. self assert: (self addressAfter: freeChunk) = followingAddress. (self isInOldSpace: objOop) ifTrue: [totalFreeOldSpace := totalFreeOldSpace + delta. self addToFreeList: freeChunk bytes: delta] ifFalse: [delta := 0. self setClassIndexOf: freeChunk to: self wordSizeClassIndexPun; setFormatOf: freeChunk to: self firstLongFormat]]. self wordSize = 8 ifTrue: [self setFormatOf: objOop to: (self normalisedFormatFor: objOop indexableSize: indexableSize)]. ^delta! Item was changed: ----- Method: SpurMemoryManager>>findLargestFreeChunk (in category 'free space') ----- findLargestFreeChunk "Answer, but do not remove, the largest free chunk in the free lists." | treeNode childNode | treeNode := freeLists at: 0. treeNode = 0 ifTrue: [^nil]. [self assertValidFreeObject: treeNode. + self assert: (self bytesInBody: treeNode) >= (self numFreeLists * self allocationUnit). - self assert: (self bytesInObject: treeNode) >= (self numFreeLists * self allocationUnit). childNode := self fetchPointer: self freeChunkLargerIndex ofFreeChunk: treeNode. childNode ~= 0] whileTrue: [treeNode := childNode]. ^treeNode! Item was changed: ----- Method: SpurMemoryManager>>freeObject: (in category 'free space') ----- freeObject: objOop "Free an object in oldSpace. Coalesce if possible to reduce fragmentation." <api> <inline: false> | bytes start next | self assert: (self isInOldSpace: objOop). (self isRemembered: objOop) ifTrue: [scavenger forgetObject: objOop]. + bytes := self bytesInBody: objOop. - bytes := self bytesInObject: objOop. start := self startOfObject: objOop. next := self objectStartingAt: start + bytes. (self isFreeObject: next) ifTrue: [self detachFreeObject: next. + bytes := bytes + (self bytesInBody: next)]. - bytes := bytes + (self bytesInObject: next)]. totalFreeOldSpace := totalFreeOldSpace + bytes. ^self freeChunkWithBytes: bytes at: start! Item was changed: ----- Method: SpurMemoryManager>>freeSpaceCharacterisation (in category 'debug support') ----- freeSpaceCharacterisation <doNotGenerate> | n s | n := 0. s := Bag new. self allFreeObjectsDo: + [:f| n := n + 1. s add: (self bytesInBody: f)]. - [:f| n := n + 1. s add: (self bytesInObject: f)]. ^{ n. s sortedCounts. s sortedElements }! Item was changed: ----- Method: SpurMemoryManager>>freeTreeNodesDo: (in category 'free space') ----- freeTreeNodesDo: aBlock "Enumerate all nodes in the free tree (in order, smaller to larger), but *not* including the next nodes of the same size off each tree node. This is an iterative version so that the block argument can be inlined by Slang. The trick to an iterative binary tree application is to apply the function on the way back up when returning from a particular direction, in this case up from the larger child. N.B For the convenience of rebuildFreeTreeFromSortedFreeChunks aBlock *MUST* answer the freeTreeNode it was invoked with, or its replacement if it was replaced by aBlock." <inline: true> | treeNode cameFrom | treeNode := freeLists at: 0. treeNode = 0 ifTrue: [^self]. cameFrom := -1. [| smallChild largeChild | + self assert: (self bytesInBody: treeNode) >= (self numFreeLists * self allocationUnit). - self assert: (self bytesInObject: treeNode) >= (self numFreeLists * self allocationUnit). smallChild := self fetchPointer: self freeChunkSmallerIndex ofFreeChunk: treeNode. largeChild := self fetchPointer: self freeChunkLargerIndex ofFreeChunk: treeNode. self assert: (smallChild = 0 or: [treeNode = (self fetchPointer: self freeChunkParentIndex ofFreeChunk: smallChild)]). self assert: (largeChild = 0 or: [treeNode = (self fetchPointer: self freeChunkParentIndex ofFreeChunk: largeChild)]). "apply if the node has no children, or it has no large children and we're returning from the small child, or we're returning from the large child." ((smallChild = 0 and: [largeChild = 0]) or: [largeChild = 0 ifTrue: [cameFrom = smallChild] ifFalse: [cameFrom = largeChild]]) ifTrue: [treeNode := aBlock value: treeNode. "and since we've applied we must move on up" cameFrom := treeNode. treeNode := self fetchPointer: self freeChunkParentIndex ofFreeChunk: treeNode] ifFalse: [(smallChild ~= 0 and: [cameFrom ~= smallChild]) ifTrue: [treeNode := smallChild] ifFalse: [self assert: largeChild ~= 0. treeNode := largeChild]. cameFrom := -1]. treeNode ~= 0] whileTrue! Item was changed: ----- Method: SpurMemoryManager>>freeTreeOverlapCheck (in category 'free space') ----- freeTreeOverlapCheck <doNotGenerate> "Assumes no 2 consecutive free chunks" self allObjectsInFreeTreeDo: [:freeNode1| self allObjectsInFreeTreeDo: [:freeNode2| freeNode1 == freeNode2 ifFalse: [|start1 start2 end1 end2| start1 := self startOfObject: freeNode1. start2 := self startOfObject: freeNode2. + end1 := start1 + (self bytesInBody: freeNode1). + end2 := start2 + (self bytesInBody: freeNode2). - end1 := start1 + (self bytesInObject: freeNode1). - end2 := start2 + (self bytesInObject: freeNode2). " Transcript show: '['; show: start1; show: ';'; show: end1; show: '];'; cr; show: '['; show: start2; show: ';'; show: end2; show: ']'; cr. " self assert: (start2 > end1 or: [end2 < start1]). + self assert: (start1 > end2 or: [start1 < start2])]]]! - self assert: (start1 > end2 or: [start1 < start2])]]].! Item was changed: ----- Method: SpurMemoryManager>>fullGC (in category 'gc - global') ----- fullGC "Perform a full eager compacting GC. Answer the size of the largest free chunk." <returnTypeC: #usqLong> <inline: #never> "for profiling" needGCFlag := false. gcStartUsecs := coInterpreter ioUTCMicrosecondsNow. statMarkCount := 0. coInterpreter preGCAction: GCModeFull. self globalGarbageCollect. coInterpreter postGCAction: GCModeFull. statGCEndUsecs := coInterpreter ioUTCMicrosecondsNow. self updateFullGCStats. ^(freeLists at: 0) ~= 0 + ifTrue: [self bytesInBody: self findLargestFreeChunk] - ifTrue: [self bytesInObject: self findLargestFreeChunk] ifFalse: [0]! Item was changed: ----- Method: SpurMemoryManager>>isLargeFreeObject: (in category 'free space') ----- isLargeFreeObject: objOop + ^(self bytesInBody: objOop) >= (self numFreeLists * self allocationUnit)! - ^(self bytesInObject: objOop) >= (self numFreeLists * self allocationUnit)! Item was changed: ----- Method: SpurMemoryManager>>largeFreeChunkDistribution (in category 'compaction - analysis') ----- largeFreeChunkDistribution "This method answers a sorted collection of the free chunks >= 1,000,000 bytes long, sandwiched between nilObj and the end of memory (ignoring the large chunk often found at the end of the heap)." <doNotGenerate> | freeChunks | freeChunks := SortedCollection new. self allObjectsInFreeTreeDo: [:f| ((self addressAfter: f) < endOfMemory + and: [(self bytesInBody: f) >= 1000000]) ifTrue: - and: [(self bytesInObject: f) >= 1000000]) ifTrue: [freeChunks add: f]]. + ^{{nilObj hex. #nil}}, (freeChunks collect: [:f| {f hex. self bytesInBody: f}]), {{endOfMemory hex. #endOfMemory}}! - ^{{nilObj hex. #nil}}, (freeChunks collect: [:f| {f hex. self bytesInObject: f}]), {{endOfMemory hex. #endOfMemory}}! Item was changed: ----- Method: SpurMemoryManager>>objectsReachableFromRoots: (in category 'image segment in/out') ----- objectsReachableFromRoots: arrayOfRoots "This is part of storeImageSegmentInto:outPointers:roots:. Answer an Array of all the objects only reachable from the argument, an Array of root objects, starting with arrayOfRoots. If there is no space, answer a SmallInteger whose value is the number of slots required. This is used to collect the objects to include in an image segment on Spur, separate from creating the segment, hence simplifying the implementation. Thanks to Igor Stasenko for this idea." | freeChunk ptr start limit count oop objOop | <var: #freeChunk type: #usqInt> "& hence start & ptr are too; limit is also because of addressAfter:" <inline: #never> self assert: (self isArray: arrayOfRoots). "Mark all objects except those only reachable from the arrayOfRoots by marking each object in arrayOfRoots and then marking all reachable objects (from the system roots). This leaves unmarked only objects reachable from the arrayOfRoots. N.B. A side-effect of the marking is that all forwarders in arrayOfRoots will be followed." self assert: self allObjectsUnmarked. self markObjectsIn: arrayOfRoots. self markObjects: false. "After the mark phase all unreachable weak slots will have been nilled and all active ephemerons fired." self assert: (self isEmptyObjStack: markStack). self assert: (self isEmptyObjStack: weaklingStack). self assert: self noUnscannedEphemerons. "Now unmark the roots before collecting the transitive closure of unmarked objects accessible from the roots." self unmarkObjectsIn: arrayOfRoots. "Use the largest free chunk to answer the result." freeChunk := self allocateLargestFreeChunk. "N.B. Does /not/ update totalFreeOldSpace" + totalFreeOldSpace := totalFreeOldSpace - (self bytesInBody: freeChunk). "but must update so that growth in the markStack does not cause assert fails." - totalFreeOldSpace := totalFreeOldSpace - (self bytesInObject: freeChunk). "but must update so that growth in the markStack does not cause assert fails." ptr := start := freeChunk + self baseHeaderSize. limit := self addressAfter: freeChunk. count := 0. "First put the arrayOfRoots; order is important." self noCheckPush: arrayOfRoots onObjStack: markStack. "Now collect the roots and the transitive closure of unmarked objects from them." [self isEmptyObjStack: markStack] whileFalse: [objOop := self popObjStack: markStack. self assert: (self isMarked: objOop). count := count + 1. ptr < limit ifTrue: [self longAt: ptr put: objOop. ptr := ptr + self bytesPerOop]. oop := self fetchClassOfNonImm: objOop. (self isMarked: oop) ifFalse: [self setIsMarkedOf: oop to: true. self noCheckPush: oop onObjStack: markStack]. ((self isContextNonImm: objOop) and: [coInterpreter isStillMarriedContext: objOop]) "widow now, before the copy loop" ifTrue: [0 to: (coInterpreter numSlotsOfMarriedContext: objOop) - 1 do: [:i| oop := coInterpreter fetchPointer: i ofMarriedContext: objOop. ((self isImmediate: oop) or: [self isMarked: oop]) ifFalse: [self setIsMarkedOf: oop to: true. self noCheckPush: oop onObjStack: markStack]]] ifFalse: [0 to: (self numPointerSlotsOf: objOop) - 1 do: [:i| oop := self fetchPointer: i ofObject: objOop. ((self isImmediate: oop) or: [self isMarked: oop]) ifFalse: [self setIsMarkedOf: oop to: true. self noCheckPush: oop onObjStack: markStack]]]]. self unmarkAllObjects. "Now try and allocate the result" (count > (ptr - start / self bytesPerOop) "not enough room" or: [limit ~= ptr and: [limit - ptr <= self allocationUnit]]) ifTrue: "can't split a single word" [self freeObject: freeChunk. self checkFreeSpace: GCCheckImageSegment. ^self integerObjectOf: count]. "There's room; set the format, & classIndex and shorten." self setFormatOf: freeChunk to: self arrayFormat. self setClassIndexOf: freeChunk to: ClassArrayCompactIndex. self shorten: freeChunk toIndexableSize: count. (self isForwarded: freeChunk) ifTrue: [freeChunk := self followForwarded: freeChunk]. self possibleRootStoreInto: freeChunk. self checkFreeSpace: GCCheckImageSegment. self runLeakCheckerFor: GCCheckImageSegment. ^freeChunk! Item was changed: ----- Method: SpurMemoryManager>>printEntity: (in category 'debug printing') ----- printEntity: oop <export: true> "useful for VM debugging; use export: not api, so it will be accessible on win32 and won't be written to cointerp.h" | printFlags | printFlags := false. coInterpreter printHex: oop; space. (self addressCouldBeObj: oop) ifFalse: [^coInterpreter print: ((self isImmediate: oop) ifTrue: ['immediate'] ifFalse: ['unknown'])]. coInterpreter print: ((self isFreeObject: oop) ifTrue: ['free'] ifFalse: [(self isSegmentBridge: oop) ifTrue: ['bridge'] ifFalse: [(self isForwarded: oop) ifTrue: ['forwarder'] ifFalse: [(self classIndexOf: oop) <= self lastClassIndexPun ifTrue: [printFlags := true. 'pun/obj stack'] ifFalse: [printFlags := true. 'object']]]]); + space; printHexnpnp: (self rawNumSlotsOf: oop); print: '/'; printHexnpnp: (self bytesInBody: oop); print: '/'; printNum: (self bytesInBody: oop). - space; printHexnpnp: (self rawNumSlotsOf: oop); print: '/'; printHexnpnp: (self bytesInObject: oop); print: '/'; printNum: (self bytesInObject: oop). printFlags ifTrue: [coInterpreter space; print: ((self formatOf: oop) <= 16rF ifTrue: ['f:0'] ifFalse: ['f:']); printHexnpnp: (self formatOf: oop); print: ((self isGrey: oop) ifTrue: [' g'] ifFalse: [' .']); print: ((self isImmutable: oop) ifTrue: ['i'] ifFalse: ['.']); print: ((self isMarked: oop) ifTrue: ['m'] ifFalse: ['.']); print: ((self isPinned: oop) ifTrue: ['p'] ifFalse: ['.']); print: ((self isRemembered: oop) ifTrue: ['r'] ifFalse: ['.'])]. coInterpreter cr! Item was changed: ----- Method: SpurMemoryManager>>printFreeChunk:printAsTreeNode: (in category 'debug printing') ----- printFreeChunk: freeChunk printAsTreeNode: printAsTreeNode | numBytes | + numBytes := self bytesInBody: freeChunk. - numBytes := self bytesInObject: freeChunk. coInterpreter print: 'freeChunk '; printHexPtrnp: freeChunk. printAsTreeNode ifTrue: [coInterpreter print: ((freeChunk = (freeLists at: 0)) ifTrue: [' + '] ifFalse: [' - ']); printHexPtrnp:(self addressAfter: freeChunk)]. coInterpreter print: ' bytes '; printNum: numBytes; print: ' next '; printHexPtrnp: (self fetchPointer: self freeChunkNextIndex ofFreeChunk: freeChunk). (self isLilliputianSize: numBytes) ifFalse: [coInterpreter print: ' prev '; printHexPtrnp: (self fetchPointer: self freeChunkPrevIndex ofFreeChunk: freeChunk).]. (numBytes >= (self numFreeLists * self allocationUnit) and: [printAsTreeNode]) 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 changed: ----- Method: SpurMemoryManager>>shorten:toIndexableSize: (in category 'indexing primitive support') ----- shorten: objOop toIndexableSize: indexableSize "Reduce the number of indexable fields in objOop, an arrayFormat or longFormat object, to nSlots. Convert the unused residual to a free chunk (if in oldSpace). Answer the number of bytes returned to free memory, which may be zero." + <api> | delta | self assert: (indexableSize >= 0 and: [indexableSize < (self lengthOf: objOop)]). false ifTrue: [self runLeakCheckerFor: GCCheckShorten]. "assume no leaks before hand..." delta := self doShorten: objOop toIndexableSize: indexableSize. self assert: (self lengthOf: (self followMaybeForwarded: objOop)) = indexableSize. self cCode: [] inSmalltalk: [(checkForLeaks anyMask: GCCheckShorten) ifTrue: [coInterpreter cr; print: 'leak checking shorten...'; flush]]. self runLeakCheckerFor: GCCheckShorten. ^delta "coInterpreter printOop: objOop" "{ objOop. self objectAfter: objOop } collect: [:ea| ea hex]" "coInterpreter printOop: (self objectAfter: objOop)"! Item was changed: ----- Method: SpurMemoryManager>>sizeOfFree: (in category 'free space') ----- sizeOfFree: objOop "For compatibility with ObjectMemory, answer the size of a free chunk in bytes. Do *not* use internally." self assert: (self isFreeObject: objOop). + ^self bytesInBody: objOop! - ^self bytesInObject: objOop! Item was changed: ----- Method: SpurMemoryManager>>sizeOfLargestFreeChunk (in category 'free space') ----- sizeOfLargestFreeChunk "Answer the size of largest free chunk in oldSpace." | freeChunk | freeChunk := self findLargestFreeChunk. freeChunk ifNil: [63 to: 1 by: -1 do: [:i| (freeLists at: i) ifNotNil: + [:chunk| ^self bytesInBody: chunk]]. - [:chunk| ^self bytesInObject: chunk]]. ^0]. + ^self bytesInBody: freeChunk! - ^self bytesInObject: freeChunk! Item was changed: ----- Method: SpurMemoryManager>>sqAllocateMemorySegmentOfSize:Above:AllocatedSizeInto: (in category 'simulation only') ----- sqAllocateMemorySegmentOfSize: segmentSize Above: minAddress AllocatedSizeInto: allocSizePtrOrBlock <doNotGenerate> "Simulate heap growth by growing memory by segmentSize + a delta. To test bridges alternate the delta between 0 bytes and 1M bytes depending on the number of segments. The delta will be the distance between segments to be bridged." | delta newMemory start | self assert: segmentSize \\ memory bytesPerElement = 0. delta := segmentManager numSegments odd ifTrue: [1024 * 1024] ifFalse: [0]. "A previous shrink may have freed up memory. Don't bother to grow if there's already room. At minAddress there is a hole of segmentSize or it is the segLimit of the last segment. However there is no hole of segmentSize + delta guaranteed..." 0 to: segmentManager numSegments - 1 do: [:i| | segment bridge | segment := segmentManager segments at: i. bridge := segmentManager bridgeAt: i. (segment segLimit >= minAddress + and: [(self bytesInBody: bridge) - self bridgeSize >= (segmentSize + delta)]) ifTrue: [ - and: [(self bytesInObject: bridge) - self bridgeSize >= (segmentSize + delta)]) ifTrue: [ allocSizePtrOrBlock value: segmentSize. ^ segment segLimit + delta] ]. start := memory size * memory bytesPerElement + delta. newMemory := memory class new: memory size + (segmentSize + delta / memory bytesPerElement). newMemory replaceFrom: 1 to: memory size with: memory startingAt: 1. memory := newMemory. allocSizePtrOrBlock value: segmentSize. ^start! Item was changed: ----- Method: SpurMemoryManager>>swizzleFieldsOfFreeChunk: (in category 'snapshot') ----- swizzleFieldsOfFreeChunk: chunk <inline: true> | field chunkBytes | field := self fetchPointer: self freeChunkNextIndex ofFreeChunk: chunk. field ~= 0 ifTrue: [self storePointerNoAssert: self freeChunkNextIndex ofFreeChunk: chunk withValue: (segmentManager swizzleObj: field in: chunk)]. + chunkBytes := self bytesInBody: chunk. - chunkBytes := self bytesInObject: chunk. false ifTrue: "The prevPointer is not guaranteed to be valid in older images. updateListStartingAt: via updateFreeLists does restore the prev pointer in all small free lists, so simply avoid swizzling it now." [(self isLilliputianSize: chunkBytes) ifFalse: [field := self fetchPointer: self freeChunkPrevIndex ofFreeChunk: chunk. field ~= 0 ifTrue: [self storePointerNoAssert: self freeChunkPrevIndex ofFreeChunk: chunk withValue: (segmentManager swizzleObj: field in: chunk)]]]. chunkBytes >= (self numFreeLists * self allocationUnit) ifTrue: [self freeChunkParentIndex to: self freeChunkLargerIndex do: [:index| field := self fetchPointer: index ofFreeChunk: chunk. field ~= 0 ifTrue: [self storePointerNoAssert: index ofFreeChunk: chunk withValue: (segmentManager swizzleObj: field in: chunk)]]]! Item was changed: ----- Method: SpurMemoryManager>>totalByteSizeOf: (in category 'indexing primitive support') ----- totalByteSizeOf: oop <returnTypeC: #usqLong> ^(self isImmediate: oop) ifTrue: [0] + ifFalse: [self bytesInBody: oop]! - ifFalse: [self bytesInObject: oop]! Item was changed: ----- Method: SpurMemoryManager>>totalFreeListBytes (in category 'free space') ----- totalFreeListBytes "This method both computes the actual number of free bytes by traversing all free objects on the free lists/tree, and checks that the tree is valid. It is used mainly by checkFreeSpace." | totalFreeBytes bytesInChunk listNode nextNode | totalFreeBytes := 0. 1 to: self numFreeLists - 1 do: [:i| bytesInChunk := i * self allocationUnit. listNode := freeLists at: i. [listNode ~= 0] whileTrue: [totalFreeBytes := totalFreeBytes + bytesInChunk. self assertValidFreeObject: listNode. + self assert: bytesInChunk = (self bytesInBody: listNode). - self assert: bytesInChunk = (self bytesInObject: listNode). nextNode := self fetchPointer: self freeChunkNextIndex ofFreeChunk: listNode. self assert: nextNode ~= listNode. listNode := nextNode]]. self freeTreeNodesDo: [:treeNode| + bytesInChunk := self bytesInBody: treeNode. - bytesInChunk := self bytesInObject: treeNode. self assert: bytesInChunk / self allocationUnit >= self numFreeLists. listNode := treeNode. [listNode ~= 0] whileTrue: ["self printFreeChunk: listNode" self assertValidFreeObject: listNode. self assert: (listNode = treeNode or: [(self fetchPointer: self freeChunkParentIndex ofFreeChunk: listNode) = 0]). totalFreeBytes := totalFreeBytes + bytesInChunk. + self assert: bytesInChunk = (self bytesInBody: listNode). - self assert: bytesInChunk = (self bytesInObject: listNode). nextNode := self fetchPointer: self freeChunkNextIndex ofFreeChunk: listNode. self assert: nextNode ~= listNode. listNode := nextNode]. treeNode]. ^totalFreeBytes! Item was changed: ----- Method: SpurMemoryManager>>unlinkFreeChunk:atIndex:isLilliputianSize: (in category 'free space') ----- unlinkFreeChunk: chunk atIndex: index isLilliputianSize: lilliputian "Unlink and answer a small chunk from one of the fixed size freeLists" <inline: true> "inlining is important because isLilliputianSize: is often true" |next| + self assert: ((self bytesInBody: chunk) = (index * self allocationUnit) + and: [index > 1 "a.k.a. (self bytesInBody: chunk) > self allocationUnit" - self assert: ((self bytesInObject: chunk) = (index * self allocationUnit) - and: [index > 1 "a.k.a. (self bytesInObject: chunk) > self allocationUnit" and: [(self startOfObject: chunk) = chunk]]). "For some reason the assertion is not compiled correctly" + self cCode: '' inSmalltalk: [self assert: (self isLilliputianSize: (self bytesInBody: chunk)) = lilliputian]. - self cCode: '' inSmalltalk: [self assert: (self isLilliputianSize: (self bytesInObject: chunk)) = lilliputian]. freeLists at: index put: (next := self fetchPointer: self freeChunkNextIndex ofFreeChunk: chunk). (lilliputian not and: [next ~= 0]) ifTrue: [self storePointer: self freeChunkPrevIndex ofFreeChunk: next withValue: 0]. ^chunk! Item was changed: ----- Method: SpurMemoryManager>>updateListStartingAt: (in category 'initialization') ----- updateListStartingAt: freeNode |prev obj| freeNode = 0 ifTrue: [^self]. + self deny: (self isLilliputianSize: (self bytesInBody: freeNode)). - self deny: (self isLilliputianSize: (self bytesInObject: freeNode)). prev := freeNode. self storePointer: self freeChunkPrevIndex ofFreeChunk: prev withValue: 0. [obj := self fetchPointer: self freeChunkNextIndex ofFreeChunk: prev. obj ~= 0] whileTrue: [self storePointer: self freeChunkPrevIndex ofFreeChunk: obj withValue: prev. prev := obj]! Item was changed: ----- Method: SpurMemoryManager>>validFreeTreeChunk:parent: (in category 'free space') ----- validFreeTreeChunk: chunk parent: parent <var: 'reason' type: #'const char *'> <returnTypeC: #'const char *'> chunk = 0 ifTrue: [^nil]. (self addressCouldBeOldObj: chunk) ifFalse: [^'not in old space']. + (self bytesInBody: chunk) / self allocationUnit < self numFreeLists ifTrue: - (self bytesInObject: chunk) / self allocationUnit < self numFreeLists ifTrue: [^'too small']. parent ~= (self fetchPointer: self freeChunkParentIndex ofFreeChunk: chunk) ifTrue: [^'bad parent']. (segmentManager segmentContainingObj: chunk) ~~ (segmentManager segmentContainingObj: (self addressAfter: chunk)) ifTrue: [^'not in one segment']. (self validFreeTreeChunk: (self fetchPointer: self freeChunkSmallerIndex ofFreeChunk: chunk) parent: chunk) ifNotNil: [:reason| ^reason]. (self validFreeTreeChunk: (self fetchPointer: self freeChunkLargerIndex ofFreeChunk: chunk) parent: chunk) ifNotNil: [:reason| ^reason]. ^nil! Item was changed: ----- Method: SpurPlanningCompactor>>coalesceFrom: (in category 'private') ----- coalesceFrom: maybeStartOfFree "manager printOopsFrom: maybeStartOfFree to: manager endOfMemory" <var: 'maybeStartOfFree' type: #usqInt> |obj next objBytes nextBytes| <var: 'obj' type: #usqInt> <var: 'next' type: #usqInt> maybeStartOfFree >= manager endOfMemory ifTrue: [^self]. obj := manager objectStartingAt: maybeStartOfFree. [next := manager oldSpaceObjectAfter: obj. next < manager endOfMemory] whileTrue: [((manager isFreeObject: obj) and: [manager isFreeObject: next]) ifTrue: + [objBytes := manager bytesInBody: obj. + nextBytes := manager bytesInBody: next. - [objBytes := manager bytesInObject: obj. - nextBytes := manager bytesInObject: next. manager unlinkFreeChunk: obj chunkBytes: objBytes. manager unlinkFreeChunk: next chunkBytes: nextBytes. obj := manager freeChunkWithBytes: objBytes + nextBytes at: (manager startOfObject: obj)] ifFalse: [obj := next]]! Item was changed: ----- Method: SpurPlanningCompactor>>copyAndUnmarkMobileObjects (in category 'compaction') ----- copyAndUnmarkMobileObjects "Sweep the mobile portion of the heap, moving objects to their eventual locations, and clearing their marked bits. Remember to update the savedFirstFields of pointer objects, as these have been forwarded. Answer if the end of the heap was reached (savedFirstFieldsSpace has not overflowed). The enumerations in planCompactSavingForwarders, updatePointersInMobileObjects and copyAndUnmarkMobileObjects match. We could implement them as a single enumeration method taking several block arguments, but arguably that would make understanding an already tricky algorithm more difficult. Instead we tolerate the duplication and encourage the reader to diff the three methods to see where they diverge (e.g. via Cmd-shift-C)." <inline: #never> | toFinger top previousPin startOfPreviousPin | <var: 'o' type: #usqInt> <var: 'top' type: #usqInt> <var: 'toFinger' type: #usqInt> <var: 'previousPin' type: #usqInt> <var: 'startOfPreviousPin' type: #usqInt> self deny: (manager isMarked: firstFreeObject). toFinger := manager startOfObject: firstFreeObject. top := savedFirstFieldsSpace start. startOfPreviousPin := 0. manager allOldSpaceEntitiesForCompactingFrom: firstFreeObject to: (lastMobileObject ifNil: manager nilObject) do: [:o :n| self check: o. self assert: (previousPin ifNil: [toFinger <= (manager startOfObject: o)] ifNotNil: [(manager isMarked: previousPin) and: [toFinger <= startOfPreviousPin]]). self assert: (savedFirstFieldsSpaceNotInOldSpace or: [toFinger < top]). (manager isMarked: o) ifTrue: [(manager isPinned: o) ifTrue: [previousPin ifNil: [previousPin := o. startOfPreviousPin := manager startOfObject: o]] ifFalse: [| availableSpace bytes | + bytes := manager bytesInBody: o. - bytes := manager bytesInObject: o. [toFinger <= startOfPreviousPin and: [bytes ~= (availableSpace := startOfPreviousPin - toFinger) and: [bytes + (2 * manager allocationUnit) > availableSpace]]] whileTrue: ["The object does not fit in the space between toFinger and previousPin. Move toFinger up to point at the first unmarked or mobile object after previousPin, or, if previousPin is contiguous with o, to the start of this object. Update previousPin to be the next pinned object above toFInger and below this object, or nil if no such pinned object exists. Any unfillable gaps between adjacent pinned objects will be freed." availableSpace > 0 ifTrue: [manager addFreeChunkWithBytes: availableSpace at: toFinger]. [self assert: ((manager isMarked: previousPin) and: [manager isPinned: previousPin]). self unmarkPinned: previousPin. toFinger := manager addressAfter: previousPin. previousPin := manager objectStartingAt: toFinger. (manager isMarked: previousPin) and: [(manager isPinned: previousPin) and: [previousPin < o]]] whileTrue. "Now previousPin is either equal to o or mobile. Move it to the next pinned object below o" [previousPin >= o or: [(manager isMarked: previousPin) and: [manager isPinned: previousPin]]] whileFalse: [previousPin := manager oldSpaceObjectAfter: previousPin]. previousPin >= o ifTrue: [previousPin := nil. startOfPreviousPin := 0] ifFalse: [startOfPreviousPin := manager startOfObject: previousPin]]. self copyAndUnmarkObject: o to: toFinger bytes: bytes firstField: (manager longAt: top). toFinger := toFinger + bytes. (top := top + manager bytesPerOop) >= savedFirstFieldsSpace limit ifTrue: [self assert: savedFirstFieldsSpace top = (top - manager bytesPerOop). self assert: n = objectAfterLastMobileObject. previousPin ifNil: [previousPin := n. startOfPreviousPin := manager startOfObject: n]. "Create a free object for firstFreeObject to be set to on the next pass, but do not link it into the free tree as it will be written over in that next pass." toFinger < startOfPreviousPin ifTrue: [firstFreeObject := manager initFreeChunkWithBytes: startOfPreviousPin - toFinger at: toFinger] ifFalse: [firstFreeObject := previousPin]. ^false]]]]. self freeFrom: toFinger upTo: manager endOfMemory nextObject: (previousPin ifNil: [objectAfterLastMobileObject ifNil: [manager objectAfter: firstFreeObject]]). self coalesceFrom: toFinger. ^true! Item was changed: ----- Method: SpurPlanningCompactor>>findHighestSuitableFreeBlock: (in category 'space management') ----- findHighestSuitableFreeBlock: spaceEstimate "If a freeBlock of size at least spaceEstimate exists high enough in the heap, choose it. Ignoring pinned objects for now, the total ammount of shrinkage is expected to be at least totalFreeOldSpace (because of collected objects). So any free chunk which is at or above endOfMemory - totalFreeOldSpace should not be corrupted during compaction. Let's play with this for a while and see how we get on." <inline: true> manager findLargestFreeChunk ifNotNil: [:largestFreeChunk| + ((manager bytesInBody: largestFreeChunk) >= spaceEstimate - ((manager bytesInObject: largestFreeChunk) >= spaceEstimate and: [largestFreeChunk asUnsignedInteger > (manager endOfMemory - manager freeSize) asUnsignedInteger]) ifTrue: [^largestFreeChunk]]. ^nil! Item was changed: ----- Method: SpurPlanningCompactor>>planCompactSavingForwarders (in category 'compaction') ----- planCompactSavingForwarders "Sweep the heap from firstFreeObject forwarding marked objects to where they can be moved to, saving their forwarding pointer in savedFirstFieldsSpace. Continue until either the end of the heap is reached or savedFirstFieldsSpace is full. Answer if the end of the heap was reached (savedFirstFieldsSpace has not overflowed). The enumerations in planCompactSavingForwarders, updatePointersInMobileObjects and copyAndUnmarkMobileObjects match. We could implement them as a single enumeration method taking several block arguments, but arguably that would make understanding an already tricky algorithm more difficult. Instead we tolerate the duplication and encourage the reader to diff the three methods to see where they diverge (e.g. via Cmd-shift-C)." <inline: #never> | toFinger top previousPin startOfPreviousPin | <var: 'o' type: #usqInt> <var: 'top' type: #usqInt> <var: 'toFinger' type: #usqInt> <var: 'previousPin' type: #usqInt> <var: 'startOfPreviousPin' type: #usqInt> savedFirstFieldsSpace top < savedFirstFieldsSpace start ifTrue: [self logPhase: 'planning...']. self deny: (manager isMarked: firstFreeObject). toFinger := manager startOfObject: firstFreeObject. top := savedFirstFieldsSpace start. startOfPreviousPin := 0. manager allOldSpaceEntitiesFrom: firstFreeObject do: [:o| self check: o. self assert: (previousPin ifNil: [toFinger <= (manager startOfObject: o)] ifNotNil: [(manager isMarked: previousPin) and: [toFinger <= startOfPreviousPin]]). self assert: (savedFirstFieldsSpaceNotInOldSpace or: [toFinger < top]). (manager isMarked: o) ifTrue: [(manager isPinned: o) ifTrue: [previousPin ifNil: [previousPin := o. startOfPreviousPin := manager startOfObject: o]] ifFalse: [| availableSpace bytes | + bytes := manager bytesInBody: o. - bytes := manager bytesInObject: o. [toFinger <= startOfPreviousPin and: [bytes ~= (availableSpace := startOfPreviousPin - toFinger) and: [bytes + (2 * manager allocationUnit) > availableSpace]]] whileTrue: ["The object does not fit in the space between toFinger and previousPin. Move toFinger up to point at the first unmarked or mobile object after previousPin, or, if previousPin is contiguous with o, to the start of this object. Update previousPin to be the next pinned object above toFInger and below this object, or nil if no such pinned object exists. Any unfillable gaps between adjacent pinned objects will be freed." [toFinger := manager addressAfter: previousPin. previousPin := manager objectStartingAt: toFinger. (manager isMarked: previousPin) and: [(manager isPinned: previousPin) and: [previousPin < o]]] whileTrue. "Now previousPin is either equal to o or mobile. Move it to the next pinned object below o" [previousPin >= o or: [(manager isMarked: previousPin) and: [manager isPinned: previousPin]]] whileFalse: [previousPin := manager oldSpaceObjectAfter: previousPin]. previousPin >= o ifTrue: [previousPin := nil. startOfPreviousPin := 0] ifFalse: [startOfPreviousPin := manager startOfObject: previousPin]]. self forwardMobileObject: o to: toFinger savedFirstFieldPtr: top. toFinger := toFinger + bytes. (top := top + manager bytesPerOop) >= savedFirstFieldsSpace limit ifTrue: [savedFirstFieldsSpace top: top - manager bytesPerOop. objectAfterLastMobileObject := manager oldSpaceObjectAfter: lastMobileObject. ^false]]]]. "If the heap is already fully compacted there will be no lastMobileObject..." lastMobileObject ifNotNil: [savedFirstFieldsSpace top: top - manager bytesPerOop. objectAfterLastMobileObject := manager oldSpaceObjectAfter: lastMobileObject]. ^true! Item was changed: ----- Method: SpurPlanningCompactor>>unmarkObjectsFromFirstFreeObject (in category 'compaction') ----- unmarkObjectsFromFirstFreeObject "Sweep the final immobile heap, freeing and coalescing unmarked and free objects, and unmarking all marked objects up to the end of memory." | startOfFree freeBytes | freeBytes := 0. manager allOldSpaceEntitiesFrom: firstFreeObject do: [:o| self check: o. (manager isMarked: o) ifFalse: [startOfFree ifNil: [startOfFree := manager startOfObject: o]. + freeBytes := freeBytes + (manager bytesInBody: o)] - freeBytes := freeBytes + (manager bytesInObject: o)] ifTrue: [startOfFree ifNotNil: [manager addFreeChunkWithBytes: freeBytes at: startOfFree. startOfFree := nil. freeBytes := 0]. (manager isPinned: o) ifTrue: [self unmarkPinned: o] ifFalse: [manager setIsMarkedOf: o to: false]]]. startOfFree ifNotNil: + [manager addFreeChunkWithBytes: freeBytes at: startOfFree]! - [manager addFreeChunkWithBytes: freeBytes at: startOfFree].! Item was changed: ----- Method: SpurPlanningCompactor>>updatePointersInMobileObjects (in category 'compaction') ----- updatePointersInMobileObjects "Sweep the mobile portion of the heap, updating all references to objects to their eventual locations. Remember to update the savedFirstFields of pointer objects, as these have been forwarded. Answer if the end of the heap was reached (savedFirstFieldsSpace has not overflowed). The enumerations in planCompactSavingForwarders, updatePointersInMobileObjects and copyAndUnmarkMobileObjects match. We could implement them as a single enumeration method taking several block arguments, but arguably that would make understanding an already tricky algorithm more difficult. Instead we tolerate the duplication and encourage the reader to diff the three methods to see where they diverge (e.g. via Cmd-shift-C)." | toFinger top previousPin startOfPreviousPin | <var: 'o' type: #usqInt> <var: 'top' type: #usqInt> <var: 'toFinger' type: #usqInt> <var: 'previousPin' type: #usqInt> <var: 'startOfPreviousPin' type: #usqInt> self deny: (manager isMarked: firstFreeObject). toFinger := manager startOfObject: firstFreeObject. top := savedFirstFieldsSpace start. startOfPreviousPin := 0. manager allOldSpaceEntitiesFrom: firstFreeObject do: [:o| self check: o. self assert: (previousPin ifNil: [toFinger <= (manager startOfObject: o)] ifNotNil: [(manager isMarked: previousPin) and: [toFinger <= startOfPreviousPin]]). (manager isMarked: o) ifTrue: [(manager isPinned: o) ifTrue: [previousPin ifNil: [previousPin := o. startOfPreviousPin := manager startOfObject: o]. self updatePointersIn: o] ifFalse: [| availableSpace bytes | + bytes := manager bytesInBody: o. - bytes := manager bytesInObject: o. [toFinger <= startOfPreviousPin and: [bytes ~= (availableSpace := startOfPreviousPin - toFinger) and: [bytes + (2 * manager allocationUnit) > availableSpace]]] whileTrue: ["The object does not fit in the space between toFinger and previousPin. Move toFinger up to point at the first unmarked or mobile object after previousPin, or, if previousPin is contiguous with o, to the start of this object. Update previousPin to be the next pinned object above toFInger and below this object, or nil if no such pinned object exists. Any unfillable gaps between adjacent pinned objects will be freed." [toFinger := manager addressAfter: previousPin. previousPin := manager objectStartingAt: toFinger. (manager isMarked: previousPin) and: [(manager isPinned: previousPin) and: [previousPin < o]]] whileTrue. "Now previousPin is either equal to o or mobile. Move it to the next pinned object below o" [previousPin >= o or: [(manager isMarked: previousPin) and: [manager isPinned: previousPin]]] whileFalse: [previousPin := manager oldSpaceObjectAfter: previousPin]. previousPin >= o ifTrue: [previousPin := nil. startOfPreviousPin := 0] ifFalse: [startOfPreviousPin := manager startOfObject: previousPin]]. self updatePointersIn: o savedFirstFieldPointer: top. toFinger := toFinger + bytes. (top := top + manager bytesPerOop) >= savedFirstFieldsSpace limit ifTrue: [self assert: savedFirstFieldsSpace top = (top - manager bytesPerOop). ^false]]]]. self assert: savedFirstFieldsSpace top = (top - manager bytesPerOop). ^true! Item was changed: ----- Method: SpurPlanningCompactor>>validRelocationPlanInPass: (in category 'private') ----- validRelocationPlanInPass: onePass "Answer 0 if all the mobile objects from firstMobileObject to lastMobileObject have sane forwarding addresses, and that savedFirstFieldsSpace is of matching capacity. Otherwise answer an error code identifying the anomaly." | nMobiles toFinger | <var: 'toFinger' type: #usqInt> <var: 'destination' type: #usqInt> nMobiles := 0. toFinger := mobileStart. anomaly := nil. manager allOldSpaceEntitiesFrom: firstMobileObject do: [:o| | destination | self check: o. (manager isMarked: o) ifTrue: [(manager isPinned: o) ifFalse: [nMobiles := nMobiles + 1. destination := manager fetchPointer: 0 ofObject: o. destination >= toFinger ifFalse: [anomaly := o. ^1]. + toFinger := toFinger + (manager bytesInBody: o). - toFinger := toFinger + (manager bytesInObject: o). (self oop: o isGreaterThan: lastMobileObject) ifTrue: [anomaly := o. ^2]. o = lastMobileObject ifTrue: [^savedFirstFieldsSpace top + manager bytesPerOop - savedFirstFieldsSpace start / manager bytesPerOop = nMobiles ifTrue: [0] ifFalse: [3]]]]]. "N.B. written this way so that if there are no mobiles the expression evaluates to 0 in Smalltalk /and/ in C unsigned arithmetic." ^savedFirstFieldsSpace top + manager bytesPerOop - savedFirstFieldsSpace start / manager bytesPerOop = nMobiles ifTrue: [0] ifFalse: [4]! Item was changed: ----- Method: SpurPlanningCompactorTests>>testRandomAssortment:with: (in category 'private') ----- testRandomAssortment: random with: theVM "Test that the compactor can handle a random assortment of live, pinned, dead, and free chunks." | om lastObj obj expectedFreeSpace liveFill pinFill liveCount pinCount totalLive totalPinned pinned | random reset. "random is a read stream on 3000 random numbers; for repeatability" om := theVM objectMemory. om allOldSpaceObjectsDo: [:o| om setIsMarkedOf: o to: true. lastObj := o]. pinFill := 16r99999900. liveFill := 16r55AA0000. liveCount := pinCount := expectedFreeSpace := 0. pinned := Set new. 1000 timesRepeat: [| nSlots next newObj | nSlots := (random next * 300) rounded. "Make sure we stray into overflow size field territory." newObj := om allocateSlotsInOldSpace: nSlots format: om firstLongFormat classIndex: ClassByteArrayCompactIndex. (next := random next) > 0.95 ifTrue: "pinned" [om fillObj: newObj numSlots: nSlots with: pinFill + (pinCount := pinCount + 1); setIsPinnedOf: newObj to: true] ifFalse: "mobile" [om fillObj: newObj numSlots: nSlots with: liveFill + (liveCount := liveCount + 1)]. (next := random next) >= 0.333 ifTrue: [om setIsMarkedOf: newObj to: true. (om isPinned: newObj) ifTrue: [pinned add: newObj]] ifFalse: "dead or free" + [expectedFreeSpace := expectedFreeSpace + (om bytesInBody: newObj). - [expectedFreeSpace := expectedFreeSpace + (om bytesInObject: newObj). (om isPinned: newObj) "Must check /before/ setObjectFree: which clears all bits" ifTrue: [pinCount := pinCount - 1] ifFalse: [liveCount := liveCount - 1]. next >= 0.2 ifTrue: [om setIsMarkedOf: newObj to: false] ifFalse: [om setObjectFree: newObj]]]. totalPinned := pinCount. totalLive := liveCount. self assert: totalPinned < (totalPinned + totalLive / 10). "should average 5%" "useful pre-compaction printing:" false ifTrue: [liveCount := pinCount := 0. om allOldSpaceEntitiesFrom: (om objectAfter: lastObj) to: (om objectBefore: om endOfMemory) do: [:o| om coInterpreter print: ((om isMarked: o) ifTrue: [(((om isPinned: o) ifTrue: [pinCount := pinCount + 1] ifFalse: [liveCount := liveCount + 1]) printPaddedWith: Character space to: 3 base: 10), ' '] ifFalse: [' ']). om printEntity: o]. om allOldSpaceEntitiesFrom: (om objectAfter: lastObj) to: (om objectBefore: om endOfMemory) do: [:o| ((om isMarked: o) and: [om isPinned: o]) ifTrue: [om printEntity: o]]]. expectedFreeSpace := expectedFreeSpace + om bytesLeftInOldSpace. om compactor compact. self assert: expectedFreeSpace equals: om bytesLeftInOldSpace. self assert: om allObjectsUnmarked. "useful post-compaction printing:" false ifTrue: [liveCount := pinCount := 0. om allOldSpaceEntitiesFrom: (om objectAfter: lastObj) to: (om objectBefore: om endOfMemory) do: [:o| om coInterpreter print: ((om isFreeObject: o) ifFalse: [(((om isPinned: o) ifTrue: [pinCount := pinCount + 1] ifFalse: [liveCount := liveCount + 1]) printPaddedWith: Character space to: 3 base: 10), ' '] ifTrue: [' ']). om printEntity: o]. om allOldSpaceEntitiesFrom: (om objectAfter: lastObj) to: (om objectBefore: om endOfMemory) do: [:o| (om isPinned: o) ifTrue: [om printEntity: o]]]. "First check and/or count populations..." liveCount := pinCount := 0. om allOldSpaceObjectsFrom: (om objectAfter: lastObj) do: [:o| (om isPinned: o) ifTrue: [pinCount := pinCount + 1. self assert: (pinned includes: o)] ifFalse: [liveCount := liveCount + 1]]. self assert: totalPinned equals: pinCount. self assert: totalLive equals: liveCount. "Now check fills, which also tests update of first field on move..." liveCount := pinCount := 0. obj := lastObj. 1 to: totalLive + totalPinned do: [:n| | expectedFill actualFill | [obj := om objectAfter: obj. (om isEnumerableObject: obj) or: [obj >= om endOfMemory]] whileFalse. expectedFill := (om isPinned: obj) ifTrue: [pinFill + (pinCount := pinCount + 1)] ifFalse: [liveFill + (liveCount := liveCount + 1)]. 1 to: (om numSlotsOf: obj) do: [:i| self assert: expectedFill equals: (actualFill := om fetchPointer: i - 1 ofObject: obj)]]. "They should be the last objects..." self assert: (om isFreeObject: (om objectAfter: obj)). self assert: om endOfMemory equals: (om addressAfter: (om objectAfter: obj)). self checkForLeaksIn: om! Item was changed: ----- Method: SpurPlanningCompactorTests>>testRandomAssortmentWithNewSegment:with: (in category 'private') ----- testRandomAssortmentWithNewSegment: random with: theVM "Test that the compactor can handle a random assortment of live, pinned, dead, and free chunks, with some allocation in a new segment. No live pinned objects are created in the new segment to obtain the situation that the last segment is entirely empty after compaction. This tests shrinkage." | om pig lastObj obj expectedFreeSpace liveFill pinFill liveCount pinCount totalLive totalPinned pinned | random reset. "random is a read stream on 3000 random numbers; for repeatability" om := theVM objectMemory. om allOldSpaceObjectsDo: [:o| om setIsMarkedOf: o to: true. lastObj := o]. pinFill := 16r99999900. liveFill := 16r55AA0000. liveCount := pinCount := expectedFreeSpace := 0. pinned := Set new. 1000 timesRepeat: [| nSlots next newObj | nSlots := (random next * 300) rounded. "Make sure we stray into overflow size field territory." newObj := om allocateSlotsInOldSpace: nSlots format: om firstLongFormat classIndex: ClassByteArrayCompactIndex. (next := random next) > 0.95 ifTrue: "pinned" [om fillObj: newObj numSlots: nSlots with: pinFill + (pinCount := pinCount + 1); setIsPinnedOf: newObj to: true] ifFalse: "mobile" [om fillObj: newObj numSlots: nSlots with: liveFill + (liveCount := liveCount + 1)]. (next := random next) >= 0.333 ifTrue: [om setIsMarkedOf: newObj to: true. (om isPinned: newObj) ifTrue: [pinned add: newObj]] ifFalse: "dead or free" + [expectedFreeSpace := expectedFreeSpace + (om bytesInBody: newObj). - [expectedFreeSpace := expectedFreeSpace + (om bytesInObject: newObj). (om isPinned: newObj) "Must check /before/ setObjectFree: which clears all bits" ifTrue: [pinCount := pinCount - 1] ifFalse: [liveCount := liveCount - 1]. next >= 0.2 ifTrue: [om setIsMarkedOf: newObj to: false] ifFalse: [om setObjectFree: newObj]]]. pig := om allocateSlotsInOldSpace: (om numSlotsOfAny: om findLargestFreeChunk) format: om firstLongFormat classIndex: ClassByteArrayCompactIndex. self deny: pig isNil. self assert: 0 equals: om bytesLeftInOldSpace. om growOldSpaceByAtLeast: om growHeadroom // 2. self assert: om growHeadroom equals: om bytesLeftInOldSpace + om bridgeSize. + expectedFreeSpace := expectedFreeSpace + (om bytesInBody: pig). - expectedFreeSpace := expectedFreeSpace + (om bytesInObject: pig). 1000 timesRepeat: [| nSlots next newObj | nSlots := (random next * 300) rounded. "Make sure we stray into overflow size field territory." newObj := om allocateSlotsInOldSpace: nSlots format: om firstLongFormat classIndex: ClassByteArrayCompactIndex. "No pinned objects in second segment." om fillObj: newObj numSlots: nSlots with: liveFill + (liveCount := liveCount + 1). (next := random next) >= 0.333 ifTrue: [om setIsMarkedOf: newObj to: true. (om isPinned: newObj) ifTrue: [pinned add: newObj]] ifFalse: "dead or free" + [expectedFreeSpace := expectedFreeSpace + (om bytesInBody: newObj). - [expectedFreeSpace := expectedFreeSpace + (om bytesInObject: newObj). liveCount := liveCount - 1. next >= 0.2 ifTrue: [om setIsMarkedOf: newObj to: false] ifFalse: [om setObjectFree: newObj]]]. totalPinned := pinCount. totalLive := liveCount. self assert: totalPinned < (totalPinned + totalLive / 20). "should average 2.5%" "useful pre-compaction printing:" false ifTrue: [liveCount := pinCount := 0. om allOldSpaceEntitiesFrom: (om objectAfter: lastObj) to: (om objectBefore: om endOfMemory) do: [:o| om coInterpreter print: ((om isMarked: o) ifTrue: [(((om isPinned: o) ifTrue: [pinCount := pinCount + 1] ifFalse: [liveCount := liveCount + 1]) printPaddedWith: Character space to: 3 base: 10), ' '] ifFalse: [' ']). om printEntity: o]. om allOldSpaceEntitiesFrom: (om objectAfter: lastObj) to: (om objectBefore: om endOfMemory) do: [:o| ((om isMarked: o) and: [om isPinned: o]) ifTrue: [om printEntity: o]]]. expectedFreeSpace := expectedFreeSpace + om bytesLeftInOldSpace. om compactor compact. self assert: expectedFreeSpace equals: om bytesLeftInOldSpace. self assert: om allObjectsUnmarked. "useful post-compaction printing:" false ifTrue: [liveCount := pinCount := 0. om allOldSpaceEntitiesFrom: (om objectAfter: lastObj) to: (om objectBefore: om endOfMemory) do: [:o| om coInterpreter print: ((om isFreeObject: o) ifFalse: [(((om isPinned: o) ifTrue: [pinCount := pinCount + 1] ifFalse: [liveCount := liveCount + 1]) printPaddedWith: Character space to: 3 base: 10), ' '] ifTrue: [' ']). om printEntity: o]. om allOldSpaceEntitiesFrom: (om objectAfter: lastObj) to: (om objectBefore: om endOfMemory) do: [:o| (om isPinned: o) ifTrue: [om printEntity: o]]]. "First check and/or count populations..." liveCount := pinCount := 0. om allOldSpaceObjectsFrom: (om objectAfter: lastObj) do: [:o| (om isPinned: o) ifTrue: [pinCount := pinCount + 1. self assert: (pinned includes: o)] ifFalse: [liveCount := liveCount + 1]]. self assert: totalPinned equals: pinCount. self assert: totalLive equals: liveCount. "Now check fills, which also tests update of first field on move..." liveCount := pinCount := 0. obj := lastObj. 1 to: totalLive + totalPinned do: [:n| | expectedFill actualFill | [obj := om objectAfter: obj. (om isEnumerableObject: obj) or: [obj >= om endOfMemory]] whileFalse. expectedFill := (om isPinned: obj) ifTrue: [pinFill + (pinCount := pinCount + 1)] ifFalse: [liveFill + (liveCount := liveCount + 1)]. 1 to: (om numSlotsOf: obj) do: [:i| self assert: expectedFill equals: (actualFill := om fetchPointer: i - 1 ofObject: obj)]]. "the Last segment should be empty" self assert: (om segmentManager isEmptySegment: (om segmentManager segments at: 1)). "They should be the last objects, followed by a free object to the end fo the first segment, a bridge, then an empty segment with a single free object in it." self assert: (om isFreeObject: (om objectAfter: obj)). self assert: (om isSegmentBridge: (om objectAfter: (om objectAfter: obj))). self assert: (om isFreeObject: (om objectAfter: (om objectAfter: (om objectAfter: obj)))). self assert: om endOfMemory equals: (om addressAfter: (om objectAfter: (om objectAfter: (om objectAfter: obj)))). "And the memory should shrink if the shrinkThreshold is low enough" om shrinkThreshold: om growHeadroom. om attemptToShrink. self assert: om segmentManager numSegments = 1. self checkForLeaksIn: om! Item was changed: ----- Method: SpurPlanningCompactorTests>>testRunOfContiguousPinnedObjects (in category 'tests') ----- testRunOfContiguousPinnedObjects "Test that the compactor can handle a long run of adjacent pinned objects across which it can and must move some unpinned objects." | om expectedFreeSpace firstPinnedObj gapObj obj | om := self initializedVM objectMemory. om allOldSpaceObjectsDo: [:o| om setIsMarkedOf: o to: true]. "First create a gap" gapObj := om allocateSlotsInOldSpace: 100 format: om firstLongFormat classIndex: ClassArrayCompactIndex. om fillObj: gapObj numSlots: 100 with: om falseObject. self deny: (om isMarked: gapObj). "Now a long run of pinned objects." 20 timesRepeat: [obj := om allocateSlotsInOldSpace: 4 format: om firstLongFormat classIndex: ClassBitmapCompactIndex. om fillObj: obj numSlots: 4 with: 16r99999999; setIsPinnedOf: obj to: true; setIsMarkedOf: obj to: true. firstPinnedObj ifNil: [firstPinnedObj := obj]]. "Now something to move around it." obj := om allocateSlotsInOldSpace: 100 format: om firstLongFormat classIndex: ClassBitmapCompactIndex. om fillObj: obj numSlots: 100 with: 16r55AA55AA; setIsMarkedOf: obj to: true. "And something to move to the end of it." obj := om allocateSlotsInOldSpace: 100 format: om firstLongFormat classIndex: ClassBitmapCompactIndex. om fillObj: obj numSlots: 100 with: 16rAA55AA55; setIsMarkedOf: obj to: true. "useful debugging:""om printOopsFrom: gapObj to: om endOfMemory" + expectedFreeSpace := om bytesLeftInOldSpace + (om bytesInBody: gapObj). - expectedFreeSpace := om bytesLeftInOldSpace + (om bytesInObject: gapObj). om compactor compact. self assert: expectedFreeSpace equals: om bytesLeftInOldSpace. self assert: om allObjectsUnmarked. "The first mobile object past the pinned objects should have moved." self assert: ClassBitmapCompactIndex equals: (om classIndexOf: gapObj). self deny: (om isPinned: gapObj). 0 to: 99 do: [:i| self assert: 16r55AA55AA equals: (om fetchPointer: i ofObject: gapObj)]. "The pinned objects should not have moved." obj := firstPinnedObj. 20 timesRepeat: [self assert: ClassBitmapCompactIndex equals: (om classIndexOf: obj). 0 to: 3 do: [:i| self assert: 16r99999999 equals: (om fetchPointer: i ofObject: obj)]. obj := om objectAfter: obj]. "The last object should have moved down." self assert: ClassBitmapCompactIndex equals: (om classIndexOf: obj). self deny: (om isPinned: obj). 0 to: 99 do: [:i| self assert: 16rAA55AA55 equals: (om fetchPointer: i ofObject: obj)]. "It should be the last object..." self assert: (om isFreeObject: (om objectAfter: obj)). + self assert: om endOfMemory equals: (om addressAfter: (om objectAfter: obj))! - self assert: om endOfMemory equals: (om addressAfter: (om objectAfter: obj)) - ! Item was changed: ----- Method: SpurPlanningCompactorTests>>testRunOfNonContiguousPinnedObjects (in category 'tests') ----- testRunOfNonContiguousPinnedObjects "Test that the compactor can handle a long run of adjacent pinned objects separated by small ammounts of free space, across which it can and must move some unpinned objects." | om expectedFreeSpace firstPinnedObj gapObj obj numPins | om := self initializedVM objectMemory. om allOldSpaceObjectsDo: [:o| om setIsMarkedOf: o to: true]. "First create a gap" gapObj := om allocateSlotsInOldSpace: 100 format: om firstLongFormat classIndex: ClassArrayCompactIndex. om fillObj: gapObj numSlots: 100 with: om falseObject. self deny: (om isMarked: gapObj). "Now a long run of pinned objects." (numPins := 20) timesRepeat: [obj := om allocateSlotsInOldSpace: 4 format: om firstLongFormat classIndex: ClassBitmapCompactIndex. om fillObj: obj numSlots: 4 with: 16r99999999; setIsPinnedOf: obj to: true; setIsMarkedOf: obj to: true. firstPinnedObj ifNil: [firstPinnedObj := obj]. om allocateSlotsInOldSpace: 4 format: om firstLongFormat classIndex: ClassArrayCompactIndex]. "Now something to move around it." obj := om allocateSlotsInOldSpace: 100 format: om firstLongFormat classIndex: ClassBitmapCompactIndex. om fillObj: obj numSlots: 100 with: 16r55AA55AA; setIsMarkedOf: obj to: true. "And something to move to the end of it." obj := om allocateSlotsInOldSpace: 100 format: om firstLongFormat classIndex: ClassBitmapCompactIndex. om fillObj: obj numSlots: 100 with: 16rAA55AA55; setIsMarkedOf: obj to: true. "useful debugging:""om printOopsFrom: gapObj to: om endOfMemory" + expectedFreeSpace := om bytesLeftInOldSpace + (om bytesInBody: gapObj) + ((om bytesInBody: firstPinnedObj) * numPins). - expectedFreeSpace := om bytesLeftInOldSpace + (om bytesInObject: gapObj) + ((om bytesInObject: firstPinnedObj) * numPins). om compactor compact. self assert: expectedFreeSpace equals: om bytesLeftInOldSpace. self assert: om allObjectsUnmarked. "The first mobile object past the pinned objects should have moved." self assert: ClassBitmapCompactIndex equals: (om classIndexOf: gapObj). self deny: (om isPinned: gapObj). 0 to: 99 do: [:i| self assert: 16r55AA55AA equals: (om fetchPointer: i ofObject: gapObj)]. "The pinned objects should not have moved." obj := firstPinnedObj. 1 to: numPins do: [:n| self assert: ClassBitmapCompactIndex equals: (om classIndexOf: obj). 0 to: 3 do: [:i| self assert: 16r99999999 equals: (om fetchPointer: i ofObject: obj)]. obj := om objectAfter: obj. n < numPins ifTrue: [self assert: (om isFreeObject: obj). obj := om objectAfter: obj]]. "The last object should have moved down." self assert: ClassBitmapCompactIndex equals: (om classIndexOf: obj). self deny: (om isPinned: obj). 0 to: 99 do: [:i| self assert: 16rAA55AA55 equals: (om fetchPointer: i ofObject: obj)]. "It should be the last object..." self assert: (om isFreeObject: (om objectAfter: obj)). + self assert: om endOfMemory equals: (om addressAfter: (om objectAfter: obj))! - self assert: om endOfMemory equals: (om addressAfter: (om objectAfter: obj)) - ! Item was changed: ----- Method: SpurPlanningCompactorTests>>testRunOfNonContiguousPinnedObjectsWithSpaceInBetween (in category 'tests') ----- testRunOfNonContiguousPinnedObjectsWithSpaceInBetween "Test that the compactor can handle a long run of adjacent pinned objects separated by large ammounts of free space, into which it can and must move some unpinned objects." | om expectedFreeSpace firstPinnedObj gapObj obj numPins firstFreeObj | om := self initializedVM objectMemory. om allOldSpaceObjectsDo: [:o| om setIsMarkedOf: o to: true]. "First create a gap" gapObj := om allocateSlotsInOldSpace: 100 format: om firstLongFormat classIndex: ClassArrayCompactIndex. om fillObj: gapObj numSlots: 100 with: om falseObject. self deny: (om isMarked: gapObj). "Now a long run of pinned objects." (numPins := 10) timesRepeat: [obj := om allocateSlotsInOldSpace: 4 format: om firstLongFormat classIndex: ClassBitmapCompactIndex. om fillObj: obj numSlots: 4 with: 16r99999999; setIsPinnedOf: obj to: true; setIsMarkedOf: obj to: true. firstPinnedObj ifNil: [firstPinnedObj := obj]. obj := om allocateSlotsInOldSpace: 104 format: om firstLongFormat classIndex: ClassArrayCompactIndex. firstFreeObj ifNil: [firstFreeObj := obj]]. self deny: (om isMarked: firstFreeObj). "Now some objects to move around and into the run of pinned objects." numPins timesRepeat: [obj := om allocateSlotsInOldSpace: 100 format: om firstLongFormat classIndex: ClassBitmapCompactIndex. om fillObj: obj numSlots: 100 with: 16r55AA55AA; setIsMarkedOf: obj to: true. obj := om allocateSlotsInOldSpace: 100 format: om firstLongFormat classIndex: ClassBitmapCompactIndex. om fillObj: obj numSlots: 100 with: 16rAA55AA55; setIsMarkedOf: obj to: true]. "useful debugging:""om printOopsFrom: gapObj to: om endOfMemory" + expectedFreeSpace := om bytesLeftInOldSpace + (om bytesInBody: gapObj) + ((om bytesInBody: firstFreeObj) * numPins). - expectedFreeSpace := om bytesLeftInOldSpace + (om bytesInObject: gapObj) + ((om bytesInObject: firstFreeObj) * numPins). om compactor compact. self assert: expectedFreeSpace equals: om bytesLeftInOldSpace. self assert: om allObjectsUnmarked. "The first mobile object past the pinned objects should have moved. The pinned objects should not have moved. We should see moved obj, pinned obj, (moved obj, free obj, pinned obj) +" obj := gapObj. 1 to: numPins do: [:n| self assert: ClassBitmapCompactIndex equals: (om classIndexOf: obj). self deny: (om isPinned: obj). 0 to: 99 do: [:i| self assert: (n odd ifTrue: [16r55AA55AA] ifFalse: [16rAA55AA55]) equals: (om fetchPointer: i ofObject: obj)]. obj := om objectAfter: obj. n > 1 ifTrue: [self assert: (om isFreeObject: obj). obj := om objectAfter: obj]. self assert: ClassBitmapCompactIndex equals: (om classIndexOf: obj). self assert: (om isPinned: obj). 0 to: 3 do: [:i| self assert: 16r99999999 equals: (om fetchPointer: i ofObject: obj)]. obj := om objectAfter: obj]. "The last objects should have moved down." 1 to: numPins do: [:n| self assert: ClassBitmapCompactIndex equals: (om classIndexOf: obj). self deny: (om isPinned: obj). 0 to: 99 do: [:i| self assert: (n odd ifTrue: [16r55AA55AA] ifFalse: [16rAA55AA55]) equals: (om fetchPointer: i ofObject: obj)].. obj := om objectAfter: obj]. "They should be the last objects..." self assert: (om isFreeObject: obj). + self assert: om endOfMemory equals: (om addressAfter: obj)! - self assert: om endOfMemory equals: (om addressAfter: obj) - ! Item was changed: ----- Method: SpurPlanningCompactorTests>>testRunOfObjectsWithExtraSegment (in category 'tests') ----- testRunOfObjectsWithExtraSegment "Test that the compactor can handle compacting more than one segment and shortening the memory." | om expectedFreeSpace pig gapObj obj | om := self initializedVM objectMemory. om allOldSpaceObjectsDo: [:o| om setIsMarkedOf: o to: true]. "First create a gap" gapObj := om allocateSlotsInOldSpace: 100 format: om firstLongFormat classIndex: ClassArrayCompactIndex. om fillObj: gapObj numSlots: 100 with: om falseObject. self deny: (om isMarked: gapObj). + expectedFreeSpace := om bytesInBody: gapObj. - expectedFreeSpace := om bytesInObject: gapObj. "Now some objects, a gap to a new segment and another run of objects." 1 to: 2 do: [:i| 10 timesRepeat: [obj := om allocateSlotsInOldSpace: 50 format: om firstLongFormat classIndex: ClassBitmapCompactIndex. om fillObj: obj numSlots: 50 with: 16r55AA55AA; setIsMarkedOf: obj to: true. obj := om allocateSlotsInOldSpace: 260 format: om firstLongFormat classIndex: ClassBitmapCompactIndex. om fillObj: obj numSlots: 260 with: 16rAA55AA55; setIsMarkedOf: obj to: true]. i = 1 ifTrue: [pig := om allocateSlotsInOldSpace: (om numSlotsOfAny: om findLargestFreeChunk) format: om firstLongFormat classIndex: ClassBitmapCompactIndex. self deny: pig isNil. self assert: 0 equals: om bytesLeftInOldSpace. om growOldSpaceByAtLeast: om growHeadroom // 2. self assert: om growHeadroom equals: om bytesLeftInOldSpace + om bridgeSize. + expectedFreeSpace := expectedFreeSpace + (om bytesInBody: pig)]]. - expectedFreeSpace := expectedFreeSpace + (om bytesInObject: pig)]]. "useful debugging:""om printOopsFrom: gapObj to: om endOfMemory" expectedFreeSpace := expectedFreeSpace + om bytesLeftInOldSpace. om compactor compact. self assert: expectedFreeSpace equals: om bytesLeftInOldSpace. self assert: om allObjectsUnmarked. "The first mobile object past the pinned objects should have moved." self assert: ClassBitmapCompactIndex equals: (om classIndexOf: gapObj). obj := gapObj. "The objects have moved." 20 timesRepeat: [self assert: ClassBitmapCompactIndex equals: (om classIndexOf: obj). 0 to: (om numSlotsOf: obj) - 1 do: [:i| self assert: 16r55AA55AA equals: (om fetchPointer: i ofObject: obj)]. obj := om objectAfter: obj. self assert: ClassBitmapCompactIndex equals: (om classIndexOf: obj). 0 to: (om numSlotsOf: obj) - 1 do: [:i| self assert: 16rAA55AA55 equals: (om fetchPointer: i ofObject: obj)]. obj := om objectAfter: obj]. "the Last segment should be empty" self assert: (om segmentManager isEmptySegment: (om segmentManager segments at: 1)). "They should be the last objects, followed by a free object to the end fo the first segment, a bridge, then an empty segment with a single free object in it." self assert: (om isFreeObject: obj). self assert: (om isSegmentBridge: (om objectAfter: obj)). self assert: (om isFreeObject: (om objectAfter: (om objectAfter: obj))). self assert: om endOfMemory equals: (om addressAfter: (om objectAfter: (om objectAfter: obj))). "And the memory should shrink if the shrinkThreshold is low enough" om shrinkThreshold: om growHeadroom. om attemptToShrink. self assert: om segmentManager numSegments = 1! Item was changed: ----- Method: SpurSegmentManager>>firstGapOfSizeAtLeast: (in category 'growing/shrinking memory') ----- firstGapOfSizeAtLeast: size "Answer the segment limit of the first segment followed by a gap of at least size bytes." 0 to: numSegments - 2 do: [:i| | bridge | bridge := self bridgeAt: i. + (manager bytesInBody: bridge) - manager bridgeSize >= size ifTrue: - (manager bytesInObject: bridge) - manager bridgeSize >= size ifTrue: [^(segments at: i) segLimit asVoidPointer]]. ^(segments at: numSegments - 1) segLimit asVoidPointer! Item was changed: ----- Method: SpurSegmentManager>>initializeFromFreeChunks: (in category 'simulation only') ----- initializeFromFreeChunks: freeChunks <doNotGenerate> "For testing, create a set of segments using the freeChunks as bridges." self assert: (freeChunks allSatisfy: [:f| manager hasOverflowHeader: f]). numSegments := freeChunks size. freeChunks do: [:f| + manager initSegmentBridgeWithBytes: (manager bytesInBody: f) at: (manager startOfObject: f). - manager initSegmentBridgeWithBytes: (manager bytesInObject: f) at: (manager startOfObject: f). self assert: (manager isSegmentBridge: f)]. segments := (1 to: numSegments) collect: [:i| | bridge start size | bridge := freeChunks at: i. start := i = 1 ifTrue: [manager newSpaceLimit] ifFalse: [manager addressAfter: (freeChunks at: i - 1)]. size := bridge + manager baseHeaderSize - start. SpurSegmentInfo new segStart: start; segSize: size; yourself]. manager setEndOfMemory: segments last segLimit. segments := CArrayAccessor on: segments. freeChunks with: segments object do: [:bridge :segment| self assert: (self isValidSegmentBridge: bridge). self assert: bridge = (self bridgeFor: segment)]! Item was changed: ----- Method: SpurSelectiveCompactor>>compactSegment:freeStart:segIndex: (in category 'compaction') ----- compactSegment: segInfo freeStart: initialFreeStart segIndex: segIndex <var: 'segInfo' type: #'SpurSegmentInfo *'> | currentEntity fillStart bytesToCopy bridge copy | fillStart := initialFreeStart. bridge := manager segmentManager bridgeFor: segInfo. currentEntity := manager objectStartingAt: segInfo segStart. self deny: segIndex = 0. "Cannot compact seg 0" lastLilliputianChunk := self lastLilliputianChunkAtIndex: segIndex - 1. [self oop: currentEntity isLessThan: bridge] whileTrue: [(manager isFreeObject: currentEntity) ifTrue: ["To avoid confusing too much Spur (especially the leak/free checks), we mark the free chunk as a word object." + (manager isLilliputianSize: (manager bytesInBody: currentEntity)) - (manager isLilliputianSize: (manager bytesInObject: currentEntity)) ifTrue: [self incrementalUnlinkLilliputianChunk: currentEntity] "Performance hack for single linked list" ifFalse: [manager detachFreeObject: currentEntity]. manager set: currentEntity classIndexTo: manager wordSizeClassIndexPun formatTo: manager wordIndexableFormat] ifFalse: ["Copy the object in segmentToFill and replace it by a forwarder." self assert: (manager isPinned: currentEntity) not. + bytesToCopy := manager bytesInBody: currentEntity. - bytesToCopy := manager bytesInObject: currentEntity. manager memcpy: fillStart asVoidPointer _: (manager startOfObject: currentEntity) asVoidPointer _: bytesToCopy. copy := manager objectStartingAt: fillStart. (manager isRemembered: copy) ifTrue: ["copy has the remembered bit set, but is not in the remembered table." manager setIsRememberedOf: copy to: false. scavenger remember: copy]. manager forward: currentEntity to: (manager objectStartingAt: fillStart). fillStart := fillStart + bytesToCopy. self assert: (self oop: fillStart isLessThan: (segmentToFill segLimit - manager bridgeSize))]. currentEntity := manager objectAfter: currentEntity limit: manager endOfMemory]. self assert: currentEntity = bridge. ^ fillStart! Item was changed: ----- Method: SpurSelectiveCompactor>>globalSweepAndSegmentOccupationAnalysis (in category 'sweep phase') ----- globalSweepAndSegmentOccupationAnalysis <inline: #never> "profiling" "Iterate over old space, free unmarked objects, annotate each segment with each occupation" | currentEntity nextBridge segmentIndex currentUsed currentUnused | lastLilliputianChunk := 0. "performance hack for single linked list" currentEntity := manager firstObject. nextBridge := manager segmentManager bridgeAt: 0. segmentIndex := currentUnused := currentUsed := 0. self setLastLilliputianChunkAtindex: 0 to: 0. [self oop: currentEntity isLessThan: manager endOfMemory] whileTrue: [currentEntity = nextBridge "End of segment, set occupation" ifTrue: [self setOccupationAtIndex: segmentIndex used: currentUsed unused: currentUnused. self setLastLilliputianChunkAtindex: segmentIndex to: lastLilliputianChunk. currentUnused := currentUsed := 0. segmentIndex := segmentIndex + 1. nextBridge := manager segmentManager bridgeAt: segmentIndex] ifFalse: [(self canUseAsFreeSpace: currentEntity) "In-segment, sweep and compute occupation" ifTrue: [currentEntity := self bulkFreeChunkFrom: currentEntity. + currentUnused := currentUnused + (manager bytesInBody: currentEntity)] - currentUnused := currentUnused + (manager bytesInObject: currentEntity)] ifFalse: [self unmark: currentEntity. + currentUsed := currentUsed + (manager bytesInBody: currentEntity)]]. - currentUsed := currentUsed + (manager bytesInObject: currentEntity)]]. currentEntity := manager objectAfter: currentEntity limit: manager endOfMemory]. "set last segment details" self setOccupationAtIndex: segmentIndex used: currentUsed unused: currentUnused. self setLastLilliputianChunkAtindex: segmentIndex to: lastLilliputianChunk. "we set the nextFreeChunk of last chunk at the end of the loop to avoid to set it at each iteration" lastLilliputianChunk ~= 0 ifTrue: [manager setNextFreeChunkOf: lastLilliputianChunk withValue: 0 isLilliputianSize: true]. manager checkFreeSpace: GCModeFull. + manager unmarkSurvivingObjectsForCompact! - manager unmarkSurvivingObjectsForCompact.! Item was changed: ----- Method: SpurSelectiveCompactor>>incrementalLilliputianSmallChunk: (in category 'compaction') ----- incrementalLilliputianSmallChunk: freeChunk "This is duplicate form #unlinkSmallChunk:index: for performance hack (single iteration of single linked list)" <inline: #never> "for profiling" | node next | + self assert: (manager bytesInBody: freeChunk) = (manager baseHeaderSize + manager allocationUnit). + self assert: manager lilliputianChunkIndex = ((manager bytesInBody: freeChunk) / manager allocationUnit). - self assert: (manager bytesInObject: freeChunk) = (manager baseHeaderSize + manager allocationUnit). - self assert: manager lilliputianChunkIndex = ((manager bytesInObject: freeChunk) / manager allocationUnit). lastLilliputianChunk = 0 ifTrue: "first incremental unlink" [(freeChunk = manager firstLilliputianChunk) ifTrue: [^manager unlinkFreeChunk: freeChunk atIndex: manager lilliputianChunkIndex isLilliputianSize: true] ifFalse: [lastLilliputianChunk := manager firstLilliputianChunk]]. node := manager fetchPointer: manager freeChunkNextIndex ofFreeChunk: lastLilliputianChunk. [node ~= 0] whileTrue: [self assert: node = (manager startOfObject: node). manager assertValidFreeObject: node. next := manager fetchPointer: manager freeChunkNextIndex ofFreeChunk: node. node = freeChunk ifTrue: [^manager setNextFreeChunkOf: lastLilliputianChunk withValue: next isLilliputianSize: true]. lastLilliputianChunk := node. node := next]. self error: 'freeChunk not found in lilliputian chunk free list' ! Item was changed: ----- Method: SpurSweeper>>bulkFreeChunkFrom: (in category 'sweep phase') ----- bulkFreeChunkFrom: objOop "The old space entity before objOop is necessarily a marked object. Attempts to free as many bytes from objOop start as possible, looking ahead to free contiguous freechunks / unmarked objects" | bytes start next currentObj | self assert: ((manager isMarked: objOop) not or: [manager isFreeObject: objOop]). start := manager startOfObject: objOop. currentObj := objOop. bytes := 0. + [bytes := bytes + (manager bytesInBody: currentObj). - [bytes := bytes + (manager bytesInObject: currentObj). (manager isRemembered: currentObj) ifTrue: [self assert: (manager isFreeObject: currentObj) not. scavenger forgetObject: currentObj]. next := manager objectStartingAt: start + bytes. self assert: ((manager oop: next isLessThan: manager endOfMemory) or: [next = manager endOfMemory and: [(self canUseAsFreeSpace: next) not]]). self canUseAsFreeSpace: next] whileTrue: [currentObj := next]. ^self interceptAddFreeChunkWithBytes: bytes at: start!

1 0

Build failed: opensmalltalk-vm 1.0.2458
by AppVeyor 23 Jun '21

23 Jun '21

1 0

[OpenSmalltalk/opensmalltalk-vm] 6ac29d: CogVM source as per VMMaker.oscog-eem.2972
by Eliot Miranda 23 Jun '21

23 Jun '21

Branch: refs/heads/Cog Home: https://github.com/OpenSmalltalk/opensmalltalk-vm Commit: 6ac29da4756edbd03f4fe9311145bbd63ece960d https://github.com/OpenSmalltalk/opensmalltalk-vm/commit/6ac29da4756edbd03f… Author: Eliot Miranda <eliot.miranda(a)gmail.com> Date: 2021-06-22 (Tue, 22 Jun 2021) Changed paths: M spur64src/vm/cogit.h M spur64src/vm/cointerp.c M spur64src/vm/cointerp.h M spur64src/vm/cointerpmt.c M spur64src/vm/cointerpmt.h M spur64src/vm/gcc3x-cointerp.c M spur64src/vm/gcc3x-cointerpmt.c M spurlowcode64src/vm/cogit.h M spurlowcode64src/vm/cointerp.c M spurlowcode64src/vm/cointerp.h M spurlowcode64src/vm/gcc3x-cointerp.c M spurlowcodesrc/vm/cogit.h M spurlowcodesrc/vm/cointerp.c M spurlowcodesrc/vm/cointerp.h M spurlowcodesrc/vm/gcc3x-cointerp.c M spurlowcodestack64src/vm/gcc3x-interp.c M spurlowcodestack64src/vm/interp.c M spurlowcodestacksrc/vm/gcc3x-interp.c M spurlowcodestacksrc/vm/interp.c M spursista64src/vm/cogit.h M spursista64src/vm/cointerp.c M spursista64src/vm/cointerp.h M spursista64src/vm/gcc3x-cointerp.c M spursistasrc/vm/cogit.h M spursistasrc/vm/cointerp.c M spursistasrc/vm/cointerp.h M spursistasrc/vm/gcc3x-cointerp.c M spursrc/vm/cogit.h M spursrc/vm/cointerp.c M spursrc/vm/cointerp.h M spursrc/vm/cointerpmt.c M spursrc/vm/cointerpmt.h M spursrc/vm/gcc3x-cointerp.c M spursrc/vm/gcc3x-cointerpmt.c M spurstack64src/vm/gcc3x-interp.c M spurstack64src/vm/interp.c M spurstack64src/vm/validImage.c M spurstacksrc/vm/gcc3x-interp.c M spurstacksrc/vm/interp.c M spurstacksrc/vm/validImage.c M src/plugins/B2DPlugin/B2DPlugin.c M src/vm/cogit.h M src/vm/cointerp.c M src/vm/cointerp.h M src/vm/gcc3x-cointerp.c M stacksrc/vm/gcc3x-interp.c M stacksrc/vm/interp.c Log Message: ----------- CogVM source as per VMMaker.oscog-eem.2972 Fix the woefully broken Spur shorten:toIndexableSize: which is needed for ImageSegment loading and was hanging on by a thread. To support this allow slimbridges throughout new space, and hence use objectAfterMaybeSlimBridge:limit: in place of objectAfter:limit: in all new space enumeration. Extend leak checking with GCCheckShorten, renaming all non-GC leak check operarions that used to use GCModeXXX names to GCCheckXXX. TestingPrimitives is now one of the names defines at compile time.

1 0

VM Maker: VMMaker.oscog-eem.2972.mcz
by commits＠source.squeak.org 23 Jun '21

23 Jun '21

Eliot Miranda uploaded a new version of VMMaker to project VM Maker: http://source.squeak.org/VMMaker/VMMaker.oscog-eem.2972.mcz ==================== Summary ==================== Name: VMMaker.oscog-eem.2972 Author: eem Time: 22 June 2021, 3:08:58.533933 pm UUID: d3fd6149-f8a8-495d-bdb0-57456ffa277c Ancestors: VMMaker.oscog-eem.2971 Fix th woefully broken Spur shorten:toIndexableSize: which is needed ror ImageSegment loading and was hanging on by a thread. To support this allow slimbridges throughout new space, and hence use objectAfterMaybeSlimBridge:limit: in place of objectAfter:limit: in all new space enumeration. Also implement SpurMemoryManager>>memcpy:_:_: more fully. Extend leak checking with GCCheckShorten, renaming all non-GC leak check operarions that used to use GCModeXXX names to GCCheckXXX. Have cloneSimulation update byteCountText for evidence of progress when doing several slow leak checks. TestingPrimitives is now one of the names defines at compile time. =============== Diff against VMMaker.oscog-eem.2971 =============== Item was changed: ----- Method: BalloonEnginePlugin>>bitmapValue:bits:atX:y: (in category 'fills-bitmaps') ----- bitmapValue: bmFill bits: bits atX: xp y: yp | bmDepth bmRaster value rShift cMask r g b a | <inline: true> bmDepth := self bitmapDepthOf: bmFill. bmRaster := self bitmapRasterOf: bmFill. bmDepth = 32 ifTrue: [ + value := (self cCoerce: bits to: 'int *') at: (bmRaster * yp) + xp. - value := (self cCoerce: bits to:'int*') at: (bmRaster * yp) + xp. (value ~= 0 and: [(value bitAnd: 16rFF000000) = 0]) ifTrue: [value := value bitOr: 16rFF000000]. ^self uncheckedTransformColor: value]. "rShift - shift value to convert from pixel to word index" rShift := self rShiftTable at: bmDepth. value := self makeUnsignedFrom: + ((self cCoerce: bits to: 'int *') at: (bmRaster * yp) + (xp >> rShift)). - ((self cCoerce: bits to:'int*') at: (bmRaster * yp) + (xp >> rShift)). "cMask - mask out the pixel from the word" cMask := (1 << bmDepth) - 1. "rShift - shift value to move the pixel in the word to the lowest bit position" rShift := 32 - bmDepth - ((xp bitAnd: (1 << rShift - 1)) * bmDepth). value := (value >> rShift) bitAnd: cMask. bmDepth = 16 ifTrue: [ "Must convert by expanding bits" value = 0 ifFalse: [ b := (value bitAnd: 31) << 3. b := b + (b >> 5). g := (value >> 5 bitAnd: 31) << 3. g := g + (g >> 5). r := (value >> 10 bitAnd: 31) << 3. r := r + (r >> 5). a := 255. value := b + (g << 8) + (r << 16) + (a << 24)]. ] ifFalse: [ "Must convert by using color map" (self bitmapCmSizeOf: bmFill) = 0 ifTrue: [value := 0] ifFalse: [value := self makeUnsignedFrom: ((self colormapOf: bmFill) at: value)]. ]. + ^self uncheckedTransformColor: value! - ^self uncheckedTransformColor: value.! Item was changed: ----- Method: CogVMSimulator>>cloneSimulation (in category 'debug support') ----- cloneSimulation | savedDisplayView savedDisplayForm savedQuitBlock savedTranscript | savedDisplayView := displayView. displayView := nil. savedDisplayForm := displayForm. displayForm = nil. savedQuitBlock := quitBlock. quitBlock := nil. savedTranscript := transcript. transcript := nil. ^[| theClone | + self changed: #byteCountText. Smalltalk garbageCollect. theClone := self veryDeepCopy. theClone parent: self; transcript: Transcript. theClone objectMemory parent: objectMemory. theClone] ensure: [displayView := savedDisplayView. displayForm = savedDisplayForm. quitBlock := savedQuitBlock. transcript := savedTranscript]! Item was changed: ----- Method: InterpreterPrimitives>>primitiveTestShortenIndexableSize (in category 'object access primitives') ----- primitiveTestShortenIndexableSize "Given an object with indexable pointer fields, reduce the size of the indexable fields to the requested size. Answer the number of bytes freed, or zero if the object cannot be shortened." <option: #TestingPrimitives> <export: true> + | array newSizeOop | + newSizeOop := self stackTop. - | array newSize bytesFreed | - newSize := self stackIntegerValue: 0. array := self stackValue: 1. + ((objectMemory isIntegerObject: newSizeOop) + and: [(objectMemory integerValueOf: newSizeOop) between: 0 and: (self stSizeOf: array) - 1]) ifFalse: + [^self primitiveFailFor: PrimErrBadArgument]. + (objectMemory canShorten: array) ifFalse: + [^self primitiveFailFor: PrimErrBadReceiver]. + self methodReturnInteger: (objectMemory + shorten: array + toIndexableSize: (objectMemory integerValueOf: newSizeOop))! - self pop: argumentCount + 1. - bytesFreed := self shorten: array toIndexableSize: newSize. - self pushInteger: bytesFreed! Item was added: + ----- Method: Spur32BitMMLECoSimulator>>shorten:toIndexableSize: (in category 'indexing primitive support') ----- + shorten: objOop toIndexableSize: indexableSize + self leakCheckShorten ifTrue: + [parent ifNil: + [| result | + result := coInterpreter cloneSimulation objectMemory shorten: objOop toIndexableSize: indexableSize. + Smalltalk garbageCollect]]. + ^super shorten: objOop toIndexableSize: indexableSize! Item was added: + ----- Method: Spur32BitMMLESimulator>>shorten:toIndexableSize: (in category 'indexing primitive support') ----- + shorten: objOop toIndexableSize: indexableSize + self leakCheckShorten ifTrue: + [parent ifNil: + [| result | + result := coInterpreter cloneSimulation objectMemory shorten: objOop toIndexableSize: indexableSize. + Smalltalk garbageCollect]]. + ^super shorten: objOop toIndexableSize: indexableSize! Item was changed: ----- Method: Spur32BitMemoryManager>>changeClassOf:to: (in category 'interpreter access') ----- changeClassOf: rcvr to: argClass "Attempt to change the class of the receiver to the argument given that the format of the receiver matches the format of the argument. If successful, answer 0, otherwise answer an error code indicating the reason for failure. Fail if the format of the receiver is incompatible with the format of the argument, or if the argument is a fixed class and the receiver's size differs from the size that an instance of the argument should have." <inline: false> | classFormat fixedFields instFormat newFormat classIndex instSlots instBytes | (self isObjImmutable: rcvr) ifTrue: [^PrimErrNoModification]. classFormat := self formatOfClass: argClass. fixedFields := self fixedFieldsOfClassFormat: classFormat. classFormat := self instSpecOfClassFormat: classFormat. instFormat := self formatOf: rcvr. "Fail for inability to access classIndex before making contexts snapshot-safe." (classIndex := self ensureBehaviorHash: argClass) < 0 ifTrue: [^classIndex negated]. "Now check the instance for compatibility and compute odd bits if necessary." classFormat <= self lastPointerFormat ifTrue: [instFormat > self lastPointerFormat ifTrue: [^PrimErrInappropriate]. ((instSlots := self numSlotsOf: rcvr) < fixedFields or: [instSlots > fixedFields and: [self isFixedSizePointerFormat: classFormat]]) ifTrue: [^PrimErrBadReceiver]. (instFormat = self indexablePointersFormat and: [self isContextNonImm: rcvr]) ifTrue: [coInterpreter makeContextSnapshotSafe: rcvr]. newFormat := classFormat] ifFalse: ["Fail if the class's format is somehow invalid." + classFormat ~= (self classFormatFromInstFormat: classFormat) ifTrue: - classFormat ~= (self classFormatForInstanceFormat: classFormat) ifTrue: [^PrimErrBadArgument]. instBytes := self numBytesOf: rcvr. classFormat caseOf: { [self sixtyFourBitIndexableFormat] -> [(instBytes anyMask: 7) ifTrue: [^PrimErrBadReceiver]. newFormat := classFormat]. [self firstLongFormat] -> [(instBytes anyMask: 3) ifTrue: [^PrimErrBadReceiver]. newFormat := classFormat]. [self firstShortFormat] -> [(instBytes anyMask: 1) ifTrue: [^PrimErrBadReceiver]. newFormat := classFormat + (2 - (instBytes >> 1) bitAnd: 1)]. [self firstByteFormat] -> [newFormat := classFormat + (4 - instBytes bitAnd: 3)]. [self firstCompiledMethodFormat] -> [classFormat ~= self firstCompiledMethodFormat ifTrue: [^PrimErrInappropriate]. newFormat := instFormat] } otherwise: "bits instances cannot be adopted by pointer-like classes..." [^PrimErrInappropriate]]. self set: rcvr classIndexTo: classIndex formatTo: newFormat. self assert: (self numBytesOf: rcvr) = (classFormat <= self lastPointerFormat ifTrue: [instSlots * self bytesPerOop] ifFalse: [instBytes]). "ok" ^0! Item was changed: ----- Method: Spur32BitMemoryManager>>hackSlimBridgeTo:at: (in category 'object enumeration-private') ----- + hackSlimBridgeTo: objOop at: startAddress - hackSlimBridgeTo: firstEdenObject at: lastWordInPastSpace "This is a horrible hack for getting to the first object in eden if pastSpace is almost full. If there is only one (64-bit) word at the end of pastSpace there is no room for a full bridge, but there is room for this hack." self flag: #endianness. + self assert: (self oop: startAddress isLessThan: objOop). + self assert: (self oop: objOop isLessThanOrEqualTo: oldSpaceStart). + self assert: (startAddress + self allocationUnit = objOop + or: [startAddress + self allocationUnit + self allocationUnit = objOop]). + self longAt: startAddress + put: (startAddress + self allocationUnit = objOop ifTrue: [0] ifFalse: [1]). + self longAt: startAddress + 4 + put: self numSlotsMask << self numSlotsHalfShift! - self assert: lastWordInPastSpace = pastSpaceStart. - self assert: lastWordInPastSpace + self baseHeaderSize = scavenger eden start. - self longAt: lastWordInPastSpace - put: (firstEdenObject = scavenger eden start ifTrue: [0] ifFalse: [1]). - self longAt: lastWordInPastSpace + 4 put: self numSlotsMask << self numSlotsHalfShift! Item was added: + ----- Method: Spur32BitMemoryManager>>normalisedFormatFor:indexableSize: (in category 'indexing primitive support') ----- + normalisedFormatFor: objOop indexableSize: indexableSize + "Answer the format for an objOop clone with indexableSize. Needs to work for longFormat and arrayFormat only." + ^self classFormatFromInstFormat: (self formatOf: objOop)! Item was changed: ----- Method: Spur32BitMemoryManager>>numSlotsForShortening:toIndexableSize: (in category 'allocation') ----- numSlotsForShortening: objOop toIndexableSize: indexableSize <inline: true> + ^(self formatOf: objOop) + caseOf: + { [self arrayFormat] -> [indexableSize]. + [self firstLongFormat] -> [self numSlotsForBytes: indexableSize * 4] } + otherwise: + [self assertf: 'invalid format for shortening'. 0]! - ^(self formatOf: objOop) caseOf: - { [self arrayFormat] -> [indexableSize]. - [self firstLongFormat] -> [self numSlotsForBytes: indexableSize * 4] }! Item was changed: ----- Method: Spur32BitMemoryManager>>objectAfterMaybeSlimBridge:limit: (in category 'object enumeration-private') ----- objectAfterMaybeSlimBridge: objOop limit: limit "Object parsing. 1. all objects have at least a word following the header, for a forwarding pointer. 2. objects with an overflow size have a preceding word with a saturated numSlots. If the word following an object doesn't have a saturated numSlots field it must be a single-header object. If the word following does have a saturated numSlots it must be the overflow size word. This variation on objectAfter:limit: allows for a single (64-bit) word bridge which may be needed to bridge from an almost full pastSpace to eden. It is only used in the flat enumerators that use startAddressForBridgedHeapEnumeration and enumerate over pastSpace, eden and oldSpace in that order. Note that the order for allObjects, and allInstances enumerates over oldSpace first. This hack is cheap. It increases the size of the objectAfter code, but saves two extra copies of the inner loop, since the inner loop now enumerates over all of pastSpace, eden and oldSpace. The test for a slim bridge is only performed if applied to an overflow header, and typically only 1 in 400 objects have overflow headers in 32-bits, 1 in 500 in 64-bits. The complication is that image segment loading evaporates the word array by setting the overflow slots to 1, and this is ambiguous with a slimbridge. The resolution is that slimbridges are used only in new space." <inline: true> | followingWordAddress followingWord | followingWordAddress := self addressAfter: objOop. (self oop: followingWordAddress isGreaterThanOrEqualTo: limit) ifTrue: [^limit]. self flag: #endianness. followingWord := self longAt: followingWordAddress + 4. ^followingWord >> self numSlotsHalfShift = self numSlotsMask + ifTrue: [((self oop: objOop isLessThan: oldSpaceStart) - ifTrue: [((self oop: objOop isGreaterThanOrEqualTo: oldSpaceStart) and: [1 = (self longAt: followingWordAddress)]) "i.e. the raw overflow slots in the overflow word" + ifTrue: [followingWordAddress + self baseHeaderSize + self baseHeaderSize] "skip the one word slimbridge" - ifTrue: [followingWordAddress + self baseHeaderSize + self baseHeaderSize] ifFalse: [followingWordAddress + self baseHeaderSize]] ifFalse: [followingWordAddress]! Item was changed: ----- Method: Spur32BitMemoryManager>>rawOverflowSlotsOf:put: (in category 'object access') ----- rawOverflowSlotsOf: objOop put: numSlots <returnTypeC: #usqInt> <inline: true> self flag: #endianness. - self deny: (numSlots = 1 and: [self oop: objOop isLessThan: newSpaceLimit]). "otherwise ambiguous with a slimbridge" ^self longAt: objOop - self baseHeaderSize put: numSlots! Item was removed: - ----- Method: Spur32BitMemoryManager>>shorten:toIndexableSize: (in category 'allocation') ----- - shorten: objOop toIndexableSize: indexableSize - "Reduce the number of indexable fields in objOop, a pointer object, to nSlots. Convert the - unused residual to a free chunk. Without changes to numSlotsForShortening:toIndexableSize: - this only works for arrayFormat and longFormat objects. - Answer the number of bytes returned to free memory, which may be zero if no change - was possible." - <inline: false> - <api> - | numSlots bytesBefore delta copy freeChunk | - self assert: (self oop: (self addressAfter: objOop) isLessThanOrEqualTo: endOfMemory). - numSlots := self numSlotsForShortening: objOop toIndexableSize: indexableSize. - numSlots = (self numSlotsOf: objOop) ifTrue: - [^0]. - bytesBefore := self bytesInObject: objOop. - delta := bytesBefore - (self objectBytesForSlots: numSlots). - - (delta > 0 - and: [delta <= self allocationUnit]) ifTrue: - [copy := self allocateSlots: numSlots - format: (self formatOf: objOop) - classIndex: (self classIndexOf: objOop). - copy ifNil: [self error: 'shorten:toIndexableSize: attempted to shorten to allocationUnit!!']. - 0 to: numSlots - 1 do: - [:i| - self storePointerUnchecked: i - ofObject: copy - withValue: (self fetchPointer: i ofObject: objOop)]. - (self isRemembered: objOop) ifTrue: - [scavenger remember: copy]. - self forward: objOop to: copy. - ^0]. - - (self hasOverflowHeader: objOop) - ifTrue: - [self rawOverflowSlotsOf: objOop put: numSlots. - numSlots < self numSlotsMask ifTrue: - [delta := delta - self allocationUnit]] - ifFalse: - [self assert: numSlots < self numSlotsMask. - self rawNumSlotsOf: objOop put: numSlots]. - - self assert: (self oop: (self addressAfter: objOop) + delta isLessThanOrEqualTo: endOfMemory). - "Since the 32-bit system rounds objects up to 64-bits, loosing - a slot may not actually change the bytes occupied by the object." - delta = 0 ifTrue: - [^0]. - - freeChunk := self initFreeChunkWithBytes: delta at: (self addressAfter: objOop). - self assert: (self addressAfter: freeChunk) <= endOfMemory. - (self isInOldSpace: objOop) - ifTrue: - [totalFreeOldSpace := totalFreeOldSpace + delta. - self addToFreeList: freeChunk bytes: delta] - ifFalse: - [self - setClassIndexOf: freeChunk to: self wordSizeClassIndexPun; - setFormatOf: freeChunk to: self firstLongFormat]. - ^delta! Item was added: + ----- Method: Spur32BitMemoryManager>>updateFormatOfShortenedObject:to: (in category 'indexing primitive support') ----- + updateFormatOfShortenedObject: objOop to: indexableSize + "This is currently a noop on 32-bits. It will need to be implemented if + shortening of 16-bit or 8-bit pure bits objects is ever supported."! Item was added: + ----- Method: Spur64BitMMLECoSimulator>>shorten:toIndexableSize: (in category 'indexing primitive support') ----- + shorten: objOop toIndexableSize: indexableSize + self leakCheckShorten ifTrue: + [parent ifNil: + [| result | + result := coInterpreter cloneSimulation objectMemory shorten: objOop toIndexableSize: indexableSize. + Smalltalk garbageCollect]]. + ^super shorten: objOop toIndexableSize: indexableSize! Item was added: + ----- Method: Spur64BitMMLESimulator>>shorten:toIndexableSize: (in category 'indexing primitive support') ----- + shorten: objOop toIndexableSize: indexableSize + self leakCheckShorten ifTrue: + [parent ifNil: + [| result | + result := coInterpreter cloneSimulation objectMemory shorten: objOop toIndexableSize: indexableSize. + Smalltalk garbageCollect]]. + ^super shorten: objOop toIndexableSize: indexableSize! Item was changed: ----- Method: Spur64BitMemoryManager>>changeClassOf:to: (in category 'interpreter access') ----- changeClassOf: rcvr to: argClass "Attempt to change the class of the receiver to the argument given that the format of the receiver matches the format of the argument. If successful, answer 0, otherwise answer an error code indicating the reason for failure. Fail if the format of the receiver is incompatible with the format of the argument, or if the argument is a fixed class and the receiver's size differs from the size that an instance of the argument should have." <inline: false> | classFormat fixedFields instFormat newFormat classIndex instSlots instBytes | (self isObjImmutable: rcvr) ifTrue: [^PrimErrNoModification]. classFormat := self formatOfClass: argClass. fixedFields := self fixedFieldsOfClassFormat: classFormat. classFormat := self instSpecOfClassFormat: classFormat. instFormat := self formatOf: rcvr. "Fail for inability to access classIndex before making contexts snapshot-safe." (classIndex := self ensureBehaviorHash: argClass) < 0 ifTrue: [^classIndex negated]. "Now check the instance for compatibility and compute odd bits if necessary." classFormat <= self lastPointerFormat ifTrue: [instFormat > self lastPointerFormat ifTrue: [^PrimErrInappropriate]. ((instSlots := self numSlotsOf: rcvr) < fixedFields or: [instSlots > fixedFields and: [self isFixedSizePointerFormat: classFormat]]) ifTrue: [^PrimErrBadReceiver]. (instFormat = self indexablePointersFormat and: [self isContextNonImm: rcvr]) ifTrue: [coInterpreter makeContextSnapshotSafe: rcvr]. newFormat := classFormat] ifFalse: ["Fail if the class's format is somehow invalid." + classFormat ~= (self classFormatFromInstFormat: classFormat) ifTrue: - classFormat ~= (self classFormatForInstanceFormat: classFormat) ifTrue: [^PrimErrBadArgument]. instBytes := self numBytesOf: rcvr. classFormat caseOf: { [self sixtyFourBitIndexableFormat] -> [(instBytes anyMask: 7) ifTrue: [^PrimErrBadReceiver]. newFormat := classFormat]. [self firstLongFormat] -> [(instBytes anyMask: 3) ifTrue: [^PrimErrBadReceiver]. newFormat := classFormat + (2 - (instBytes >> 2) bitAnd: 1)]. [self firstShortFormat] -> [(instBytes anyMask: 1) ifTrue: [^PrimErrBadReceiver]. newFormat := classFormat + (4 - (instBytes >> 1) bitAnd: 3)]. [self firstByteFormat] -> [newFormat := classFormat + (8 - instBytes bitAnd: 7)]. [self firstCompiledMethodFormat] -> [classFormat ~= self firstCompiledMethodFormat ifTrue: [^PrimErrInappropriate]. newFormat := instFormat] } otherwise: "bits instances cannot be adopted by pointer-like classes..." [^PrimErrInappropriate]]. self set: rcvr classIndexTo: classIndex formatTo: newFormat. self assert: (self numBytesOf: rcvr) = (classFormat <= self lastPointerFormat ifTrue: [instSlots * self bytesPerOop] ifFalse: [instBytes]). "ok" ^0! Item was changed: ----- Method: Spur64BitMemoryManager>>hackSlimBridgeTo:at: (in category 'object enumeration-private') ----- + hackSlimBridgeTo: objOop at: startAddress - hackSlimBridgeTo: firstEdenObject at: lastWordInPastSpace "This is a horrible hack for getting to the first object in eden if pastSpace is almost full. If there is only one (64-bit) word at the end of pastSpace there is no room for a full bridge, but there is room for this hack." + self assert: (self oop: startAddress isLessThan: objOop). + self assert: (self oop: objOop isLessThanOrEqualTo: oldSpaceStart). + self assert: (startAddress + self allocationUnit = objOop + or: [startAddress + self allocationUnit + self allocationUnit = objOop]). + self longAt: startAddress + put: (startAddress + self allocationUnit = objOop - self assert: lastWordInPastSpace = pastSpaceStart. - self assert: lastWordInPastSpace + self baseHeaderSize = scavenger eden start. - self longAt: lastWordInPastSpace - put: (firstEdenObject = scavenger eden start ifTrue: [self numSlotsMask << self numSlotsFullShift] ifFalse: [self numSlotsMask << self numSlotsFullShift + 1])! Item was added: + ----- Method: Spur64BitMemoryManager>>normalisedFormatFor:indexableSize: (in category 'indexing primitive support') ----- + normalisedFormatFor: objOop indexableSize: indexableSize + "Answer the format for an objOop clone with indexableSize. Needs to work for longFormat and arrayFormat only." + | format | + format := self classFormatFromInstFormat: (self formatOf: objOop). + ^(format = self firstLongFormat and: [indexableSize anyMask: 1]) + ifTrue: [format + 1] + ifFalse: [format]! Item was changed: ----- Method: Spur64BitMemoryManager>>numSlotsForShortening:toIndexableSize: (in category 'allocation') ----- numSlotsForShortening: objOop toIndexableSize: indexableSize <inline: true> ^(self formatOf: objOop) caseOf: { [self arrayFormat] -> [indexableSize]. [self firstLongFormat] -> [self numSlotsForBytes: indexableSize * 4]. + [self firstLongFormat + 1] -> [self numSlotsForBytes: indexableSize * 4] } + otherwise: + [self assertf: 'invalid format for shortening'. 0]! - [self firstLongFormat + 1] -> [self numSlotsForBytes: indexableSize * 4] }! Item was changed: ----- Method: Spur64BitMemoryManager>>objectAfterMaybeSlimBridge:limit: (in category 'object enumeration-private') ----- objectAfterMaybeSlimBridge: objOop limit: limit "Object parsing. 1. all objects have at least a word following the header, for a forwarding pointer. 2. objects with an overflow size have a preceding word with a saturated numSlots. If the word following an object doesn't have a saturated numSlots field it must be a single-header object. If the word following does have a saturated numSlots it must be the overflow size word. This variation on objectAfter:limit: allows for a single (64-bit) word bridge which may be needed to bridge from an almost full pastSpace to eden. It is only used in the flat enumerators that use startAddressForBridgedHeapEnumeration and enumerate over pastSpace, eden and oldSpace in that order. Note that the order for allObjects, and allInstances enumerates over oldSpace first. This hack is cheap. It increases the size of the objectAfter code, but saves two extra copies of the inner loop, since the inner loop now enumerates over all of pastSpace, eden and oldSpace. The test for a slim bridge is only performed if applied to an overflow header, and typically only 1 in 400 objects have overflow headers in 32-bits, 1 in 500 in 64-bits. The complication is that image segment loading evaporates the word array by setting the overflow slots to 1, and this is ambiguous with a slimbridge. The resolution is that slimbridges are used only in new space." <inline: true> | followingWordAddress followingWord | followingWordAddress := self addressAfter: objOop. (self oop: followingWordAddress isGreaterThanOrEqualTo: limit) ifTrue: [^limit]. self flag: #endianness. followingWord := self longAt: followingWordAddress. ^followingWord >> self numSlotsFullShift = self numSlotsMask ifTrue: + [((self oop: objOop isLessThan: oldSpaceStart) - [((self oop: objOop isGreaterThanOrEqualTo: oldSpaceStart) and: [(followingWord bitAnd: 16rFFFFFFFFFFFFFF) = 1]) + ifTrue: [followingWordAddress + self baseHeaderSize + self baseHeaderSize] "skip the one word slimbridge" - ifTrue: [followingWordAddress + self baseHeaderSize + self baseHeaderSize] ifFalse: [followingWordAddress + self baseHeaderSize]] ifFalse: [followingWordAddress]! Item was changed: ----- Method: Spur64BitMemoryManager>>rawOverflowSlotsOf:put: (in category 'object access') ----- rawOverflowSlotsOf: objOop put: numSlots <returnTypeC: #usqLong> <inline: true> self flag: #endianness. - self deny: (numSlots = 1 and: [self oop: objOop isLessThan: newSpaceLimit]). "otherwise ambiguous with a slimbridge" self longAt: objOop - self baseHeaderSize put: self numSlotsMask << 56 + numSlots. ^numSlots! Item was removed: - ----- Method: Spur64BitMemoryManager>>shorten:toIndexableSize: (in category 'allocation') ----- - shorten: objOop toIndexableSize: indexableSize - "Reduce the number of indexable fields in objOop, a pointer object, to nSlots. Convert the - unused residual to a free chunk. Without changes to numSlotsForShortening:toIndexableSize: - this only works for arrayFormat and longFormat objects. - Answer the number of bytes returned to free memory, which may be zero if no change - was possible." - <inline: false> - <api> - | numSlots bytesBefore delta copy freeChunk | - numSlots := self numSlotsForShortening: objOop toIndexableSize: indexableSize. - numSlots = (self numSlotsOf: objOop) ifTrue: - [^0]. - bytesBefore := self bytesInObject: objOop. - delta := bytesBefore - (self objectBytesForSlots: numSlots). - - self flag: 'this should update format for 32-bit indexable words; too lazy today.'. - - delta = 0 ifTrue: - [^0]. - - delta <= self allocationUnit ifTrue: - [copy := self allocateSlots: numSlots - format: (self formatOf: objOop) - classIndex: (self classIndexOf: objOop). - copy ifNil: [self error: 'shorten:toIndexableSize: attempted to shorten to allocationUnit!!']. - 0 to: numSlots - 1 do: - [:i| - self storePointerUnchecked: i - ofObject: copy - withValue: (self fetchPointer: i ofObject: objOop)]. - (self isRemembered: objOop) ifTrue: - [scavenger remember: copy]. - self forward: objOop to: copy. - ^0]. - - (self hasOverflowHeader: objOop) - ifTrue: - [self rawOverflowSlotsOf: objOop put: numSlots. - numSlots < self numSlotsMask ifTrue: - [delta := delta - self allocationUnit]] - ifFalse: - [self assert: numSlots < self numSlotsMask. - self rawNumSlotsOf: objOop put: numSlots]. - - freeChunk := self initFreeChunkWithBytes: delta at: (self addressAfter: objOop). - self assert: (self addressAfter: freeChunk) <= endOfMemory. - (self isInOldSpace: objOop) - ifTrue: - [totalFreeOldSpace := totalFreeOldSpace + delta. - self addToFreeList: freeChunk bytes: delta] - ifFalse: - [self - setClassIndexOf: freeChunk to: self wordSizeClassIndexPun; - setFormatOf: freeChunk to: self firstLongFormat]. - ^delta! Item was added: + ----- Method: Spur64BitMemoryManager>>updateFormatOfShortenedObject:to: (in category 'indexing primitive support') ----- + updateFormatOfShortenedObject: objOop to: indexableSize + "Update the odd bits of a word object, if required. It will need to be extended if + shortening of 16-bit or 8-bit pure bits objects is ever supported." + ((self formatOf: objOop) between: self firstLongFormat and: self firstLongFormat + 1) ifTrue: + [self setFormatOf: objOop to: self firstLongFormat + (indexableSize bitAnd: 1)]! Item was added: + ----- Method: SpurGenerationScavenger>>printSpaces (in category 'debug support') ----- + printSpaces + coInterpreter print: 'eden start '; printHex: eden start; print: ' end/free '; printHex: manager freeStart; print: ' limit '; printHex: eden limit; cr. + coInterpreter print: 'past start '; printHex: pastSpace start; print: ' end '; printHex: manager pastSpaceStart; print: ' limit '; printHex: pastSpace limit; cr. + coInterpreter print: 'future start '; printHex: futureSpace start; print: ' survivorStart '; printHex: futureSurvivorStart; print: ' limit '; printHex: futureSpace limit; cr! Item was changed: ----- Method: SpurImageSegmentTests>>testSaveHashedCollectionAndAllSubclasses (in category 'tests') ----- testSaveHashedCollectionAndAllSubclasses SimulatorHarnessForTests new withExecutableInterpreter: self initializedVM do: [:vm :harness| | error objects | CheckForLeaks == true ifTrue: "CheckForLeaks := self confirm: 'Check for leaks?'" + [vm objectMemory setCheckForLeaks: (vm objectMemory class bindingOf: #GCCheckImageSegment) value]. - [vm objectMemory setCheckForLeaks: (vm objectMemory class bindingOf: #GCModeImageSegment) value]. error := harness findSymbol: #error. self deny: error isNil. objects := harness interpreter: vm object: (harness findClassNamed: 'Compiler') perform: (harness findSymbol: #evaluate:) withArguments: {vm objectMemory stringForCString: '[| seg out roots result | seg := WordArray new: 1024 * 1024. out := Array new: 512. roots := HashedCollection withAllSubclasses asArray. roots := roots, (roots collect: [:ea| ea class]). (thisContext isPrimFailToken: (nil tryPrimitive: 98 withArgs: { roots. seg. out })) ifTrue: [^#error]. result := { seg. out }. (thisContext isPrimFailToken: (nil tryPrimitive: 99 withArgs: result)) ifTrue: [^#error]. result] on: Error do: [:ex| ^#error]'}. self deny: objects = error]! Item was changed: ----- Method: SpurImageSegmentTests>>testSaveHashedCollectionSubclasses (in category 'tests') ----- testSaveHashedCollectionSubclasses SimulatorHarnessForTests new withExecutableInterpreter: self initializedVM do: [:vm :harness| | error objects | CheckForLeaks == true ifTrue: "CheckForLeaks := self confirm: 'Check for leaks?'" + [vm objectMemory setCheckForLeaks: (vm objectMemory class bindingOf: #GCCheckImageSegment) value]. - [vm objectMemory setCheckForLeaks: (vm objectMemory class bindingOf: #GCModeImageSegment) value]. error := harness findSymbol: #error. self deny: error isNil. objects := harness interpreter: vm object: (harness findClassNamed: 'Compiler') perform: (harness findSymbol: #evaluate:) withArguments: {vm objectMemory stringForCString: '[| seg out roots result | seg := WordArray new: 1024 * 1024. out := Array new: 256. roots := HashedCollection subclasses asArray. roots := roots, (roots collect: [:ea| ea class]). (thisContext isPrimFailToken: (nil tryPrimitive: 98 withArgs: { roots. seg. out })) ifTrue: [^#error]. result := { seg. out }. (thisContext isPrimFailToken: (nil tryPrimitive: 99 withArgs: result)) ifTrue: [^#error]. result] on: Error do: [:ex| ^#error]'}. self deny: objects = error]! Item was changed: CogClass subclass: #SpurMemoryManager (excessive size, no diff calculated) Item was changed: ----- Method: SpurMemoryManager>>allEntitiesFrom:do: (in category 'object enumeration-private') ----- allEntitiesFrom: initialObject do: aBlock <inline: true> + | prevObj prevPrevObj obj | - | prevObj prevPrevObj objOop | prevPrevObj := prevObj := nil. + obj := initialObject. - objOop := initialObject. self enableObjectEnumerationFrom: initialObject. + [self assert: obj \\ self allocationUnit = 0. + self oop: obj isLessThan: endOfMemory] whileTrue: + [self assert: (self long64At: obj) ~= 0. + aBlock value: obj. - [self assert: objOop \\ self allocationUnit = 0. - self oop: objOop isLessThan: endOfMemory] whileTrue: - [self assert: (self long64At: objOop) ~= 0. - aBlock value: objOop. prevPrevObj := prevObj. + prevObj := obj. + obj := self objectAfterMaybeSlimBridge: obj limit: endOfMemory. + self assert: (self oop: obj isGreaterThan: prevObj)]. - prevObj := objOop. - objOop := self objectAfterMaybeSlimBridge: objOop limit: endOfMemory]. self touch: prevPrevObj. self touch: prevObj! Item was changed: ----- Method: SpurMemoryManager>>allNewSpaceEntitiesDo: (in category 'object enumeration-private') ----- allNewSpaceEntitiesDo: aBlock "Enumerate all new space objects, including free objects." <inline: true> | start prevObj prevPrevObj objOop | prevPrevObj := prevObj := nil. "After a scavenge eden is empty, futureSpace is empty, and all newSpace objects are in pastSpace. Objects are allocated in eden. So enumerate only pastSpace and eden." self assert: (scavenger pastSpace start < scavenger eden start). start := self startAddressForBridgedHeapEnumeration. start > freeStart ifTrue: [^self]. self bridgePastSpaceAndEden. objOop := self objectStartingAt: start. [self oop: objOop isLessThan: freeStart] whileTrue: [aBlock value: objOop. prevPrevObj := prevObj. prevObj := objOop. + objOop := self objectAfterMaybeSlimBridge: objOop limit: freeStart]. - objOop := self objectAfter: objOop limit: freeStart]. self touch: prevPrevObj. self touch: prevObj! Item was changed: ----- Method: SpurMemoryManager>>allPastSpaceEntitiesDo: (in category 'object enumeration-private') ----- allPastSpaceEntitiesDo: aBlock "Enumerate all past space objects, including free objects." <inline: true> | prevObj prevPrevObj objOop | prevPrevObj := prevObj := nil. objOop := self objectStartingAt: scavenger pastSpace start. [self oop: objOop isLessThan: pastSpaceStart] whileTrue: [aBlock value: objOop. prevPrevObj := prevObj. prevObj := objOop. + objOop := self objectAfterMaybeSlimBridge: objOop limit: pastSpaceStart]. - objOop := self objectAfter: objOop limit: pastSpaceStart]. self touch: prevPrevObj. self touch: prevObj! Item was added: + ----- Method: SpurMemoryManager>>canShorten: (in category 'indexing primitive support') ----- + canShorten: objOop + ^(self isNonImmediate: objOop) + and: [(self numSlotsOf: objOop) > 0 + and: [(self isArrayNonImm: objOop) or: [self isWordsNonImm: objOop]]]! Item was changed: ----- Method: SpurMemoryManager>>checkFreeSpace: (in category 'debug support') ----- checkFreeSpace: gcModes <api> self assert: self bitsSetInFreeSpaceMaskForAllFreeLists. self assert: totalFreeOldSpace = self totalFreeListBytes. (gcModes > 0 + and: [checkForLeaks allMask: (GCCheckFreeSpace bitOr: gcModes)]) ifTrue: + [self runLeakCheckerForFreeSpace: GCCheckFreeSpace ignoring: nil]! - and: [checkForLeaks allMask: (GCModeFreeSpace bitOr: gcModes)]) ifTrue: - [self runLeakCheckerForFreeSpace: GCModeFreeSpace ignoring: nil]! Item was changed: ----- Method: SpurMemoryManager>>checkFreeSpace:ignoring: (in category 'debug support') ----- checkFreeSpace: gcModes ignoring: anOopToIgnore <api> self assert: self bitsSetInFreeSpaceMaskForAllFreeLists. self assert: totalFreeOldSpace = self totalFreeListBytes. (gcModes > 0 + and: [checkForLeaks allMask: (GCCheckFreeSpace bitOr: gcModes)]) ifTrue: + [self runLeakCheckerForFreeSpace: GCCheckFreeSpace ignoring: anOopToIgnore]! - and: [checkForLeaks allMask: (GCModeFreeSpace bitOr: gcModes)]) ifTrue: - [self runLeakCheckerForFreeSpace: GCModeFreeSpace ignoring: anOopToIgnore]! Item was removed: - ----- Method: SpurMemoryManager>>classFormatForInstanceFormat: (in category 'header format') ----- - classFormatForInstanceFormat: aFormat - "Clear any odd bits from the format so that it matches its class's format" - aFormat < self firstLongFormat ifTrue: - [^aFormat]. - aFormat >= self firstByteFormat ifTrue: - [^aFormat bitAnd: -8]. - ^aFormat >= self firstShortFormat - ifTrue: [aFormat bitAnd: -4] - ifFalse: [aFormat bitAnd: -2]! Item was added: + ----- Method: SpurMemoryManager>>doShorten:toIndexableSize: (in category 'indexing primitive support') ----- + doShorten: objOop toIndexableSize: indexableSize + "Reduce the number of indexable fields in objOop, a pointer object, to nSlots. Convert the + unused residual to a free chunk. Without changes to numSlotsForShortening:toIndexableSize: + this only works for arrayFormat and longFormat objects. + Answer the number of bytes returned to free memory, which may be zero if no change + was possible." + <inline: false> + <api> + | followingAddress numSlots bytesBefore delta copy freeChunk | + followingAddress := self addressAfter: objOop. "for assert checking" + self assert: (self oop: followingAddress isLessThanOrEqualTo: endOfMemory). + numSlots := self numSlotsForShortening: objOop toIndexableSize: indexableSize. + bytesBefore := self bytesInObject: objOop. + delta := bytesBefore - (self objectBytesForSlots: numSlots). + + "Since the system rounds objects up to 64-bits, losing a 32-bit + slot may not actually change the bytes occupied by the object." + delta = 0 ifTrue: + [(self hasOverflowHeader: objOop) + ifTrue: [self rawOverflowSlotsOf: objOop put: numSlots] + ifFalse: [self rawNumSlotsOf: objOop put: numSlots]. + self updateFormatOfShortenedObject: objOop to: indexableSize. + ^0]. + + "Currently we can't have one word gaps in oldSpace but we can in newSpace. So only create + a copy and forward if objOop is in old space. If in newSpace we'll create a slimbridge below." + (delta <= self allocationUnit + and: [self isOldObject: objOop]) ifTrue: + [| format | + format := self normalisedFormatFor: objOop indexableSize: indexableSize. + copy := self allocateSlots: numSlots + format: format + classIndex: (self classIndexOf: objOop). + copy ifNil: [self error: 'shorten:toIndexableSize: attempted to shorten by allocationUnit and failed to allocate space for copy!!']. + (self isPureBitsFormat: format) + ifTrue: + [self memcpy: (self firstIndexableField: copy) + _: (self firstIndexableField: objOop) + _: (self numBytesOfBits: copy format: format)] + ifFalse: + [0 to: numSlots - 1 do: + [:i| + self storePointerUnchecked: i + ofObject: copy + withValue: (self fetchPointer: i ofObject: objOop)]]. + (self isRemembered: objOop) ifTrue: + [scavenger remember: copy]. + self forward: objOop to: copy. + ^0]. + + (self hasOverflowHeader: objOop) + ifTrue: + [self rawOverflowSlotsOf: objOop put: numSlots. + "Setting an overflow slot count to 0 or 1 in newSpace creates a slimbridge. + So we must also change the normal slot count so that the object no + longer has the overflow header word, which has become the slimbridge." + numSlots <= 1 ifTrue: + [(self oop: objOop isLessThan: oldSpaceStart) ifTrue: + [self rawNumSlotsOf: objOop put: numSlots. + self hackSlimBridgeTo: objOop at: objOop - self allocationUnit]]] + ifFalse: + [self assert: numSlots < self numSlotsMask. + self rawNumSlotsOf: objOop put: numSlots]. + + "{self addressAfter: objOop. delta. (self addressAfter: objOop) + delta. followingAddress} collect: #hex" + delta := followingAddress - (self addressAfter: objOop). + self assert: (delta >= self allocationUnit and: [delta \\ self allocationUnit = 0]). + delta = self allocationUnit + ifTrue: + [self deny: (self isOldObject: objOop). + delta := 0. + followingAddress = freeStart + ifTrue: [freeStart := self addressAfter: objOop] + ifFalse: [self hackSlimBridgeTo: followingAddress at: (self addressAfter: objOop)]] + ifFalse: + [freeChunk := self initFreeChunkWithBytes: delta at: (self addressAfter: objOop). + self assert: (self objectAfter: objOop) = freeChunk. + self assert: (self addressAfter: freeChunk) = followingAddress. + (self isInOldSpace: objOop) + ifTrue: + [totalFreeOldSpace := totalFreeOldSpace + delta. + self addToFreeList: freeChunk bytes: delta] + ifFalse: + [delta := 0. + self + setClassIndexOf: freeChunk to: self wordSizeClassIndexPun; + setFormatOf: freeChunk to: self firstLongFormat]]. + self wordSize = 8 ifTrue: + [self setFormatOf: objOop to: (self normalisedFormatFor: objOop indexableSize: indexableSize)]. + ^delta! Item was removed: - ----- Method: SpurMemoryManager>>ensureHasOverflowHeader:forwardIfCloned: (in category 'image segment in/out') ----- - ensureHasOverflowHeader: arrayArg forwardIfCloned: forwardIfCloned - "If arrayArg is too short to be truncated, clone it so that the clone is long enough. - Answer nil if it can't be cloned." - <inline: false> - (self hasOverflowHeader: arrayArg) ifTrue: - [^arrayArg]. - ^(self - allocateSlots: self numSlotsMask + 1 - format: (self formatOf: arrayArg) - classIndex: (self classIndexOf: arrayArg)) ifNotNil: - [:clonedArray| - self memcpy: clonedArray + self baseHeaderSize - _: arrayArg + self baseHeaderSize - _: (self numSlotsOf: arrayArg) * self bytesPerOop. - (self isRemembered: arrayArg) ifTrue: - [scavenger remember: clonedArray]. - forwardIfCloned ifTrue: - [self forward: arrayArg to: clonedArray]. - clonedArray]! Item was changed: ----- Method: SpurMemoryManager>>growOldSpaceByAtLeast: (in category 'growing/shrinking memory') ----- growOldSpaceByAtLeast: minAmmount "Attempt to grow memory by at least minAmmount. Answer the size of the new segment, or nil if the attempt failed." | ammount headroom total start interval | <var: #segInfo type: #'SpurSegmentInfo *'> "statGrowMemory counts attempts, not successes." statGrowMemory := statGrowMemory + 1."we need to include overhead for a new object header plus the segment bridge." ammount := minAmmount + (self baseHeaderSize * 2 + self bridgeSize). "round up to the nearest power of two." ammount := 1 << (ammount - 1) highBit. "and grow by at least growHeadroom." ammount := ammount max: growHeadroom. "Now apply the maxOldSpaceSize limit, if one is in effect." maxOldSpaceSize > 0 ifTrue: [total := segmentManager totalBytesInSegments. total >= maxOldSpaceSize ifTrue: [needGCFlag := true. ^nil]. headroom := maxOldSpaceSize - total. headroom < ammount ifTrue: [headroom < (minAmmount + (self baseHeaderSize * 2 + self bridgeSize)) ifTrue: [needGCFlag := true. ^nil]. ammount := headroom]]. start := coInterpreter ioUTCMicrosecondsNow. ^(segmentManager addSegmentOfSize: ammount) ifNil: [needGCFlag := true. nil] ifNotNil: [:segInfo| self assimilateNewSegment: segInfo. "and add the new free chunk to the free list; done here instead of in assimilateNewSegment: for the assert" self addFreeChunkWithBytes: segInfo segSize - self bridgeSize at: segInfo segStart. self assert: (self addressAfter: (self objectStartingAt: segInfo segStart)) = (segInfo segLimit - self bridgeSize). + self checkFreeSpace: GCCheckFreeSpace. - self checkFreeSpace: GCModeFreeSpace. segmentManager checkSegments. interval := coInterpreter ioUTCMicrosecondsNow - start. interval > statMaxAllocSegmentTime ifTrue: [statMaxAllocSegmentTime := interval]. segInfo segSize]! Item was changed: ----- Method: SpurMemoryManager>>inLineRunLeakCheckerFor:excludeUnmarkedObjs:classIndicesShouldBeValid: (in category 'debug support') ----- inLineRunLeakCheckerFor: gcModes excludeUnmarkedObjs: excludeUnmarkedObjs classIndicesShouldBeValid: classIndicesShouldBeValid <inline: true> (gcModes anyMask: checkForLeaks) ifTrue: [(gcModes anyMask: GCModeFull) ifTrue: [coInterpreter reverseDisplayFrom: 0 to: 7] ifFalse: [coInterpreter reverseDisplayFrom: 8 to: 15]. self clearLeakMapAndMapAccessibleObjects. self asserta: (self checkHeapIntegrity: excludeUnmarkedObjs classIndicesShouldBeValid: classIndicesShouldBeValid). self asserta: coInterpreter checkInterpreterIntegrity = 0. self asserta: coInterpreter checkStackIntegrity. self asserta: (coInterpreter checkCodeIntegrity: gcModes). + (gcModes anyMask: GCCheckFreeSpace) ifTrue: - (gcModes anyMask: GCModeFreeSpace) ifTrue: [self clearLeakMapAndMapAccessibleFreeSpace. self asserta: self checkHeapFreeSpaceIntegrity]]! Item was changed: ----- Method: SpurMemoryManager>>initializeOldSpaceFirstFree: (in category 'free space') ----- initializeOldSpaceFirstFree: startOfFreeOldSpace <var: 'startOfFreeOldSpace' type: #usqInt> | limit freeOldStart freeChunk | <var: 'limit' type: #usqInt> <var: 'freeOldStart' type: #usqInt> limit := endOfMemory - self bridgeSize. limit > startOfFreeOldSpace ifTrue: [totalFreeOldSpace := totalFreeOldSpace + (limit - startOfFreeOldSpace). freeOldStart := startOfFreeOldSpace. self wordSize > 4 ifTrue: [[limit - freeOldStart >= (1 << 32)] whileTrue: [freeChunk := self freeChunkWithBytes: (1 << 32) at: freeOldStart. freeOldStart := freeOldStart + (1 << 32). self assert: freeOldStart = (self addressAfter: freeChunk)]]. freeOldStart < limit ifTrue: [freeChunk := self freeChunkWithBytes: limit - freeOldStart at: freeOldStart. self assert: (self addressAfter: freeChunk) = limit]]. endOfMemory := endOfMemory - self bridgeSize. freeOldSpaceStart := endOfMemory. + self checkFreeSpace: GCCheckFreeSpace! - self checkFreeSpace: GCModeFreeSpace! Item was changed: ----- Method: SpurMemoryManager>>leakCheckBecome (in category 'debug support') ----- leakCheckBecome <api> + ^checkForLeaks anyMask: GCModeBecome! - ^(checkForLeaks bitAnd: GCModeBecome) ~= 0! Item was changed: ----- Method: SpurMemoryManager>>leakCheckFullGC (in category 'debug support') ----- leakCheckFullGC <api> + ^checkForLeaks anyMask: GCModeFull! - ^(checkForLeaks bitAnd: GCModeFull) ~= 0! Item was changed: ----- Method: SpurMemoryManager>>leakCheckImageSegments (in category 'debug support') ----- leakCheckImageSegments + ^checkForLeaks anyMask: GCCheckImageSegment! - ^(checkForLeaks bitAnd: GCModeImageSegment) ~= 0! Item was changed: ----- Method: SpurMemoryManager>>leakCheckIncremental (in category 'debug support') ----- leakCheckIncremental <api> + ^checkForLeaks anyMask: GCModeIncremental! - ^(checkForLeaks bitAnd: GCModeIncremental) ~= 0! Item was changed: ----- Method: SpurMemoryManager>>leakCheckNewSpaceGC (in category 'debug support') ----- leakCheckNewSpaceGC <api> + ^checkForLeaks anyMask: GCModeNewSpace! - ^(checkForLeaks bitAnd: GCModeNewSpace) ~= 0! Item was changed: ----- Method: SpurMemoryManager>>leakCheckRuntimeCalls (in category 'debug support') ----- leakCheckRuntimeCalls <doNotGenerate> + ^checkForLeaks anyMask: GCCheckPrimCall! - ^(checkForLeaks bitAnd: 32) ~= 0! Item was added: + ----- Method: SpurMemoryManager>>leakCheckShorten (in category 'debug support') ----- + leakCheckShorten + ^checkForLeaks anyMask: GCCheckShorten! Item was changed: ----- Method: SpurMemoryManager>>loadImageSegmentFrom:outPointers: (in category 'image segment in/out') ----- loadImageSegmentFrom: segmentWordArray outPointers: outPointerArray "This primitive is called from Smalltalk as... <imageSegment> loadSegmentFrom: aWordArray outPointers: anArray." "This primitive will load a binary image segment created by primitiveStoreImageSegment. It expects the outPointer array to be of the proper size, and the wordArray to be well formed. It will return as its value the original array of roots, and the segmentWordArray will become an array of the loaded objects. If this primitive should fail, the segmentWordArray will, sadly, have been reduced to an unrecognizable and unusable jumble. But what more could you have done with it anyway? The primitive, if it succeeds, also becomes the segmentWordArray into the array of loaded objects. This allows fixing up of loaded objects directly, without nextObject, which Spur doesn't support." <inline: #never> | segmentLimit segmentStart segVersion errorCode numLoadedObjects loadedObjectsArray | segmentLimit := self numSlotsOf: segmentWordArray. (self objectBytesForSlots: segmentLimit) < (self allocationUnit "version info" + self baseHeaderSize "one object header") ifTrue: [^PrimErrBadArgument halt]. "Verify format. If the format is wrong, word-swap (since ImageSegment data are 32-bit longs). If it is still wrong, undo the damage and fail." segVersion := self longAt: segmentWordArray + self baseHeaderSize. (coInterpreter readableFormat: (segVersion bitAnd: 16rFFFFFF "low 3 bytes")) ifFalse: [self reverseBytesIn32BitWordsIn: segmentWordArray. segVersion := self longAt: segmentWordArray + self baseHeaderSize. (coInterpreter readableFormat: (segVersion bitAnd: 16rFFFFFF "low 3 bytes")) ifFalse: [self reverseBytesIn32BitWordsIn: segmentWordArray. ^PrimErrBadArgument halt]]. segmentStart := segmentWordArray + self baseHeaderSize + self allocationUnit. segmentLimit := segmentLimit * self bytesPerOop + segmentWordArray + self baseHeaderSize. "Notionally reverse the Byte type objects if the data is from opposite endian machine. Test top byte. $d on the Mac or $s on the PC. Rest of word is equal. If Spur is ever ported to big-endian machines then the segment may have to be byte/word swapped, but so far it only runs on little-endian machines, so for now just fail if endianness is wrong." self flag: #endianness. (segVersion >> 24 bitAnd: 16rFF) ~= (self imageSegmentVersion >> 24 bitAnd: 16rFF) ifTrue: "Reverse the byte-type objects once" [true ifTrue: [^PrimErrBadArgument halt] ifFalse: [self byteSwapByteObjectsFrom: (self objectStartingAt: segmentStart) to: segmentLimit flipFloatsIf: false]]. "Avoid having to remember by arranging that there are no young outPointers if segment is in old space." (self isOldObject: segmentWordArray) ifTrue: [errorCode := self ensureNoNewObjectsIn: outPointerArray. errorCode ~= 0 ifTrue: [^errorCode]]. "scan through mapping oops and validating class references. Defer entering any class objects into the class table and/or pinning objects until a second pass." errorCode := self mapOopsAndValidateClassRefsFrom: segmentStart to: segmentLimit outPointers: outPointerArray. errorCode > 0 ifTrue: [^errorCode]. numLoadedObjects := errorCode negated. loadedObjectsArray := self allocateSlots: numLoadedObjects format: self arrayFormat classIndex: ClassArrayCompactIndex. loadedObjectsArray ifNil: [^PrimErrNoMemory halt]. "Scan for classes contained in the segment, entering them into the class table. Classes are at the front, after the root array and have the remembered bit set." errorCode := self enterClassesIntoClassTableFrom: segmentStart to: segmentLimit. errorCode ~= 0 ifTrue: [^errorCode]. "Make a final pass, assigning class indices and/or pinning pinned objects and collecting the loaded objects in loadedObjectsArray" self assignClassIndicesAndPinFrom: segmentStart to: segmentLimit outPointers: outPointerArray filling: loadedObjectsArray. "Evaporate the container, leaving the newly loaded objects in place." (self hasOverflowHeader: segmentWordArray) ifTrue: [self rawOverflowSlotsOf: segmentWordArray put: self allocationUnit / self bytesPerOop] ifFalse: [self rawNumSlotsOf: segmentWordArray put: self allocationUnit / self bytesPerOop]. "Finally forward the segmentWordArray to the loadedObjectsArray" self forward: segmentWordArray to: loadedObjectsArray. + self runLeakCheckerFor: GCCheckImageSegment. - self runLeakCheckerFor: GCModeImageSegment. ^self objectStartingAt: segmentStart! Item was changed: ----- Method: SpurMemoryManager>>memcpy:_:_: (in category 'simulation') ----- memcpy: destAddress _: sourceAddress _: bytes "For SpurGenerationScavenger>>copyToFutureSpace:bytes:. N.B. If ranges overlap, must use memmove." <doNotGenerate> + | nToCopy offset | + (destAddress isInteger and: [sourceAddress isInteger]) ifFalse: "CogMethodProxies..." + [sourceAddress isCollection ifTrue: "CArray, String, etc..." + [^super memcpy: destAddress _: sourceAddress _: bytes]. + ^self memcpy: destAddress asInteger _: sourceAddress asInteger _: bytes]. + self deny: ((destAddress <= sourceAddress and: [destAddress + bytes > sourceAddress]) + or: [sourceAddress <= destAddress and: [sourceAddress + bytes > destAddress]]). + self assert: (destAddress \\ 8) + (sourceAddress \\ 8) = 0. "for now..." + nToCopy := bytes. + offset := 0. + memory bytesPerElement = 8 ifTrue: + [0 to: nToCopy - 8 by: 8 do: + [:i| self long64At: destAddress + i put: (self long64At: sourceAddress + i)]. + offset := nToCopy - (nToCopy \\ 8). + nToCopy := nToCopy \\ 8]. + nToCopy >= 4 ifTrue: + [0 to: nToCopy - 4 by: 4 do: + [:i| self long32At: destAddress + i + offset put: (self long32At: sourceAddress + i + offset)]. + offset := offset + nToCopy - (nToCopy \\ 4). + nToCopy := nToCopy \\ 4]. + 0 to: nToCopy - 1 do: + [:i| self byteAt: destAddress + i + offset put: (self byteAt: sourceAddress + i + offset)]. + ^destAddress! - sourceAddress isCollection ifTrue: - [^super memcpy: destAddress _: sourceAddress _: bytes]. - self deny: ((destAddress <= sourceAddress and: [destAddress asInteger + bytes > sourceAddress]) - or: [sourceAddress <= destAddress and: [sourceAddress asInteger + bytes > destAddress]]). - ^self memmove: destAddress _: sourceAddress _: bytes! Item was added: + ----- Method: SpurMemoryManager>>numBytesOfBits:format: (in category 'object access') ----- + numBytesOfBits: objOop format: format + "Answer the number of indexable bytes in the given non-immediate pure bits object with format." + | numBytes | + <inline: true> + self assert: ((self isPureBitsFormat: format) and: [(self formatOf: objOop) = format]). + numBytes := self numSlotsOf: objOop. + numBytes := numBytes << self shiftForWord. + format < self firstShortFormat ifTrue: + [^format <= self sixtyFourBitIndexableFormat + ifTrue: [numBytes] + ifFalse: [numBytes - ((format bitAnd: 1) << 2)]]. + ^format < self firstByteFormat + ifTrue: [numBytes - ((format bitAnd: 3) << 1)] + ifFalse: [numBytes - (format bitAnd: 7)]! Item was changed: ----- Method: SpurMemoryManager>>objectsReachableFromRoots: (in category 'image segment in/out') ----- objectsReachableFromRoots: arrayOfRoots "This is part of storeImageSegmentInto:outPointers:roots:. Answer an Array of all the objects only reachable from the argument, an Array of root objects, starting with arrayOfRoots. If there is no space, answer a SmallInteger whose value is the number of slots required. This is used to collect the objects to include in an image segment on Spur, separate from creating the segment, hence simplifying the implementation. Thanks to Igor Stasenko for this idea." | freeChunk ptr start limit count oop objOop | <var: #freeChunk type: #usqInt> "& hence start & ptr are too; limit is also because of addressAfter:" <inline: #never> self assert: (self isArray: arrayOfRoots). "Mark all objects except those only reachable from the arrayOfRoots by marking each object in arrayOfRoots and then marking all reachable objects (from the system roots). This leaves unmarked only objects reachable from the arrayOfRoots. N.B. A side-effect of the marking is that all forwarders in arrayOfRoots will be followed." self assert: self allObjectsUnmarked. self markObjectsIn: arrayOfRoots. self markObjects: false. "After the mark phase all unreachable weak slots will have been nilled and all active ephemerons fired." self assert: (self isEmptyObjStack: markStack). self assert: (self isEmptyObjStack: weaklingStack). self assert: self noUnscannedEphemerons. "Now unmark the roots before collecting the transitive closure of unmarked objects accessible from the roots." self unmarkObjectsIn: arrayOfRoots. "Use the largest free chunk to answer the result." freeChunk := self allocateLargestFreeChunk. "N.B. Does /not/ update totalFreeOldSpace" totalFreeOldSpace := totalFreeOldSpace - (self bytesInObject: freeChunk). "but must update so that growth in the markStack does not cause assert fails." ptr := start := freeChunk + self baseHeaderSize. limit := self addressAfter: freeChunk. count := 0. "First put the arrayOfRoots; order is important." self noCheckPush: arrayOfRoots onObjStack: markStack. "Now collect the roots and the transitive closure of unmarked objects from them." [self isEmptyObjStack: markStack] whileFalse: [objOop := self popObjStack: markStack. self assert: (self isMarked: objOop). count := count + 1. ptr < limit ifTrue: [self longAt: ptr put: objOop. ptr := ptr + self bytesPerOop]. oop := self fetchClassOfNonImm: objOop. (self isMarked: oop) ifFalse: [self setIsMarkedOf: oop to: true. self noCheckPush: oop onObjStack: markStack]. ((self isContextNonImm: objOop) and: [coInterpreter isStillMarriedContext: objOop]) "widow now, before the copy loop" ifTrue: [0 to: (coInterpreter numSlotsOfMarriedContext: objOop) - 1 do: [:i| oop := coInterpreter fetchPointer: i ofMarriedContext: objOop. ((self isImmediate: oop) or: [self isMarked: oop]) ifFalse: [self setIsMarkedOf: oop to: true. self noCheckPush: oop onObjStack: markStack]]] ifFalse: [0 to: (self numPointerSlotsOf: objOop) - 1 do: [:i| oop := self fetchPointer: i ofObject: objOop. ((self isImmediate: oop) or: [self isMarked: oop]) ifFalse: [self setIsMarkedOf: oop to: true. self noCheckPush: oop onObjStack: markStack]]]]. self unmarkAllObjects. "Now try and allocate the result" (count > (ptr - start / self bytesPerOop) "not enough room" or: [limit ~= ptr and: [limit - ptr <= self allocationUnit]]) ifTrue: "can't split a single word" [self freeObject: freeChunk. + self checkFreeSpace: GCCheckImageSegment. - self checkFreeSpace: GCModeImageSegment. ^self integerObjectOf: count]. "There's room; set the format, & classIndex and shorten." self setFormatOf: freeChunk to: self arrayFormat. self setClassIndexOf: freeChunk to: ClassArrayCompactIndex. self shorten: freeChunk toIndexableSize: count. (self isForwarded: freeChunk) ifTrue: [freeChunk := self followForwarded: freeChunk]. self possibleRootStoreInto: freeChunk. + self checkFreeSpace: GCCheckImageSegment. + self runLeakCheckerFor: GCCheckImageSegment. - self checkFreeSpace: GCModeImageSegment. - self runLeakCheckerFor: GCModeImageSegment. ^freeChunk! Item was changed: ----- Method: SpurMemoryManager>>return:restoringObjectsIn:savedFirstFields:and:savedHashes: (in category 'image segment in/out') ----- return: errCode restoringObjectsIn: firstArray savedFirstFields: savedFirstFields and: secondArray savedHashes: savedHashes <inline: false> "This is part of storeImageSegmentInto:outPointers:roots:." self cCode: [] inSmalltalk: [errCode ~= 0 ifTrue: [self halt]]. self restoreObjectsIn: firstArray upTo: -1 savedFirstFields: savedFirstFields. self restoreObjectsIn: secondArray savedHashes: savedHashes. + self runLeakCheckerFor: GCCheckImageSegment. - self runLeakCheckerFor: GCModeImageSegment. self assert: self allObjectsUnmarked. ^errCode! Item was changed: ----- Method: SpurMemoryManager>>return:restoringObjectsIn:upTo:savedFirstFields: (in category 'image segment in/out') ----- return: errCode restoringObjectsIn: firstArray upTo: limitOrTag savedFirstFields: savedFirstFields <inline: false> "This is part of storeImageSegmentInto:outPointers:roots:." self cCode: [] inSmalltalk: [errCode ~= 0 ifTrue: [self halt]]. self restoreObjectsIn: firstArray upTo: limitOrTag savedFirstFields: savedFirstFields. + self runLeakCheckerFor: GCCheckImageSegment. - self runLeakCheckerFor: GCModeImageSegment. self assert: self allObjectsUnmarked. ^errCode! Item was changed: ----- Method: SpurMemoryManager>>runLeakCheckerForFreeSpace:ignoring: (in category 'debug support') ----- runLeakCheckerForFreeSpace: gcModes ignoring: anOopOrNil "Check free space integrity by setting bits in the map corresponding to all free space objects and checking tat no pointer field refers to a free object. anOopOrNil is provided to filter-out the as-yet-to-be initialized object in primitiveShallowCopy/primitiveClone." <inline: false> + (gcModes anyMask: GCCheckFreeSpace) ifTrue: - (gcModes anyMask: GCModeFreeSpace) ifTrue: [coInterpreter reverseDisplayFrom: 16 to: 19. self clearLeakMapAndMapAccessibleFreeSpace. freeSpaceCheckOopToIgnore := anOopOrNil. self asserta: self checkHeapFreeSpaceIntegrity. freeSpaceCheckOopToIgnore := nil]! Item was changed: ----- Method: SpurMemoryManager>>setCheckForLeaks: (in category 'spur bootstrap') ----- setCheckForLeaks: integerFlags " 0 = do nothing. 1 = check for leaks on fullGC (GCModeFull). 2 = check for leaks on scavenger (GCModeNewSpace). 4 = check for leaks on incremental (GCModeIncremental) 8 = check for leaks on become (GCModeBecome) + 16 = check for leaks on image segments (GCCheckImageSegment) + 32 = check for leaks in free space (GCCheckFreeSpace) + 64 = check for leaks on object shortening (GCCheckShorten) + 128 = check for leaks on simulated run-time call (GCCheckPrimCall)" - 16 = check for leaks on image segments (GCModeImageSegment) - 32 = check for leaks on simulated run-time call." checkForLeaks := integerFlags! Item was changed: + ----- Method: SpurMemoryManager>>shorten:toIndexableSize: (in category 'indexing primitive support') ----- - ----- Method: SpurMemoryManager>>shorten:toIndexableSize: (in category 'allocation') ----- shorten: objOop toIndexableSize: indexableSize + "Reduce the number of indexable fields in objOop, an arrayFormat or longFormat object, to nSlots. + Convert the unused residual to a free chunk (if in oldSpace). + Answer the number of bytes returned to free memory, which may be zero." + | delta | + self assert: (indexableSize >= 0 and: [indexableSize < (self lengthOf: objOop)]). + false ifTrue: [self runLeakCheckerFor: GCCheckShorten]. "assume no leaks before hand..." + delta := self doShorten: objOop toIndexableSize: indexableSize. + self assert: (self lengthOf: (self followMaybeForwarded: objOop)) = indexableSize. + self cCode: [] inSmalltalk: + [(checkForLeaks anyMask: GCCheckShorten) ifTrue: + [coInterpreter cr; print: 'leak checking shorten...'; flush]]. + self runLeakCheckerFor: GCCheckShorten. + ^delta + + "coInterpreter printOop: objOop" + "{ objOop. self objectAfter: objOop } collect: [:ea| ea hex]" + "coInterpreter printOop: (self objectAfter: objOop)"! - "Reduce the number of indexable fields in objOop, a pointer object, to nSlots. Convert the - unused residual to a free chunk. Without changes to numSlotsForShortening:toIndexableSize: - this only works for arrayFormat and longFormat objects. - Answer the number of bytes returned to free memory, which may be zero if no change was possible." - self subclassResponsibility! Item was changed: ----- Method: SpurMemoryManager>>storeImageSegmentInto:outPointers:roots: (in category 'image segment in/out') ----- storeImageSegmentInto: segmentWordArrayArg outPointers: outPointerArrayArg roots: arrayOfRootsArg "This primitive is called from Squeak as... <imageSegment> storeSegmentFor: arrayOfRoots into: aWordArray outPointers: anArray. This primitive will store a binary image segment (in the same format as objects in the heap) of the set of objects in arrayOfObjects. All pointers from within the set to objects outside the set will be copied into the array of outPointers. In their place in the image segment will be an oop equal to the offset in the outPointer array (the first would be 8), but with the high bit set. Since Spur has a class table the load primitive must insert classes that have instances into the class table. This primitive marks such classes using the isRemembered bit, which isn't meaningful as a remembered bit in the segment. The primitive expects the segmentWordArray and outPointerArray to be more than adequately long. In this case it returns normally, and truncates the two arrays to exactly the right size. The primitive can fail for the following reasons with the specified failure codes: PrimErrGenericError: the segmentWordArray is too small for the version stamp PrimErrWritePastObject: the segmentWordArray is too small to contain the reachable objects PrimErrBadIndex: the outPointerArray is too small PrimErrNoMemory: additional allocations failed PrimErrLimitExceeded: there is no room in the hash field to store out pointer indices or class references." <inline: false> | segmentWordArray outPointerArray arrayOfRoots arrayOfObjects savedFirstFields savedOutHashes segStart segAddr endSeg outIndex numClassesInSegment | <var: 'segAddr' type: #usqInt> ((self isObjImmutable: segmentWordArrayArg) or: [self isObjImmutable: outPointerArrayArg]) ifTrue: [^PrimErrNoModification]. "Since segmentWordArrayArg & outPointerArrayArg may get shortened, they can't be pinned." ((self isPinned: segmentWordArrayArg) or: [self isPinned: outPointerArrayArg]) ifTrue: [^PrimErrObjectIsPinned]. (self numSlotsOf: outPointerArrayArg) > self maxIdentityHash ifTrue: [^PrimErrLimitExceeded]. + self runLeakCheckerFor: GCCheckImageSegment. - self runLeakCheckerFor: GCModeImageSegment. "First scavenge to collect any new space garbage that refers to the graph." self scavengingGC. segmentWordArray := self updatePostScavenge: segmentWordArrayArg. outPointerArray := self updatePostScavenge: outPointerArrayArg. arrayOfRoots := self updatePostScavenge: arrayOfRootsArg. self deny: (self forwardersIn: outPointerArray). self deny: (self forwardersIn: arrayOfRoots). "Now compute the transitive closure, collecting the sequence of objects to be stored in the arrayOfObjects array. Included in arrayOfObjects are the arrayOfRoots and all its contents. All objects have been unmarked." arrayOfObjects := self objectsReachableFromRoots: arrayOfRoots. arrayOfObjects ifNil: [^PrimErrNoMemory]. "If objectsReachableFromRoots: answers an integer there is not enough continuous free space in which to allocate the reachable objects. If there is sufficient free space then answer an error code to prompt a compacting GC and a retry." (self isIntegerObject: arrayOfObjects) ifTrue: [totalFreeOldSpace - self allocationUnit >= (self integerValueOf: arrayOfObjects) ifTrue: [^PrimErrNeedCompaction]. ^PrimErrNoMemory]. self assert: self allObjectsUnmarked. "work to be done when the incremental GC is written" self deny: (self forwardersIn: arrayOfObjects). "Both to expand the max size of segment and to reduce the length of the load-time pass that adds classes to the class table, move classes to the front of arrayOfObjects, leaving the root array as the first element." numClassesInSegment := self moveClassesForwardsIn: arrayOfObjects. "The scheme is to copy the objects into segmentWordArray, and then map the oops in segmentWordArray. Therefore the primitive needs to both map efficiently originals to copies in segmentWordArray and be able to undo any side-effects if the primitive fails because either segmentWordArray or outPointerArray is too small. The mapping is done by having the objects to be stored in arrayOfObjects refer to their mapped locations through their first field, just like a forwarding pointer, but without becoming a forwarder, saving their first field in savedFirstFields, and the objects in outPointerArray pointing to their locations in the outPointerArray through their identityHashes, saved in savedOutHashes. Since arrayOfObjects and its savedFirstFields, and outPointerArray and its saved hashes, can be enumerated side-by-side, the hashes can be restored to the originals. So the first field of the heap object corresponding to an object in arrayOfObjects is set to its location in segmentWordArray, and the hash of an object in outPointerArray is set to its index in outPointerArray plus the top hash bit. Classes in arrayOfObjects have their marked bit set. Oops in objects in segmentWordArray are therefore mapped by accessing the original oop, and following its first field. Class indices in segmentWordArray are mapped by fetching the original class, and testing its marked bit. If marked, the first field is followed to access the class copy in the segment. Out pointers (objects and classes, which are unmarked), the object's identityHash is set (eek!!!!) to its index in the outPointerArray. So savedOutHashes parallels the outPointerArray. The saved hash array is initialized with an out-of-range hash value so that the first unused entry can be identified." savedFirstFields := self allocateSlots: (self numSlotsOf: arrayOfObjects) format: self wordIndexableFormat classIndex: self wordSizeClassIndexPun. savedOutHashes := self allocateSlots: (self numSlotsForBytes: (self numSlotsOf: outPointerArray) * 4) format: self firstLongFormat classIndex: self thirtyTwoBitLongsClassIndexPun. (savedFirstFields isNil or: [savedOutHashes isNil]) ifTrue: [self freeObject: arrayOfObjects. (savedFirstFields notNil and: [self isInOldSpace: savedFirstFields]) ifTrue: [self freeObject: savedFirstFields]. (savedOutHashes notNil and: [self isInOldSpace: savedOutHashes]) ifTrue: [self freeObject: savedOutHashes]. ^PrimErrNoMemory]. self fillObj: savedFirstFields numSlots: (self numSlotsOf: savedFirstFields) with: 0. self fillObj: savedOutHashes numSlots: (self numSlotsOf: savedOutHashes) with: self savedOutHashFillValue. segAddr := segmentWordArray + self baseHeaderSize. endSeg := self addressAfter: segmentWordArray. "Write a version number for byte order and version check." segAddr >= endSeg ifTrue: [^PrimErrGenericFailure]. self long32At: segAddr put: self imageSegmentVersion. self long32At: segAddr + 4 put: self imageSegmentVersion. segStart := segAddr := segAddr + self allocationUnit. self assert: arrayOfRoots = (self fetchPointer: 0 ofObject: arrayOfObjects). "Copy all reachable objects to the segment, setting the marked bit for all objects (clones) in the segment, and the remembered bit for all classes (clones) in the segment." 0 to: (self numSlotsOf: arrayOfObjects) - 1 do: [:i| | newSegAddrOrError objOop | "Check that classes in the segment are addressable. Since the top bit of the hash field is used to tag classes external to the segment, the segment offset must not inadvertently set this bit. This limit still allows for a million or more classes." (i = numClassesInSegment and: [segAddr - segStart / self allocationUnit + self lastClassIndexPun >= TopHashBit]) ifTrue: [^self return: PrimErrLimitExceeded restoringObjectsIn: arrayOfObjects upTo: i savedFirstFields: savedFirstFields]. objOop := self fetchPointer: i ofObject: arrayOfObjects. self deny: ((self isImmediate: objOop) or: [self isForwarded: objOop]). newSegAddrOrError := self copyObj: objOop toAddr: segAddr stopAt: endSeg savedFirstFields: savedFirstFields index: i. (self oop: newSegAddrOrError isLessThan: segStart) ifTrue: [^self return: newSegAddrOrError restoringObjectsIn: arrayOfObjects upTo: i savedFirstFields: savedFirstFields]. segAddr := newSegAddrOrError]. "Check that it can be safely shortened." (endSeg ~= segAddr and: [endSeg - segAddr < (self baseHeaderSize + self bytesPerOop)]) ifTrue: [^self return: PrimErrWritePastObject restoringObjectsIn: arrayOfObjects upTo: -1 savedFirstFields: savedFirstFields]. "Now scan, adding out pointers to the outPointersArray; all objects in arrayOfObjects have their first field pointing to the corresponding copy in segmentWordArray." (outIndex := self mapOopsFrom: segStart to: segAddr outPointers: outPointerArray outHashes: savedOutHashes) < 0 ifTrue: "no room in outPointers; fail" [^self return: PrimErrBadIndex restoringObjectsIn: arrayOfObjects savedFirstFields: savedFirstFields and: outPointerArray savedHashes: savedOutHashes]. "We're done. Shorten the results, restore hashes and return." self shorten: segmentWordArray toIndexableSize: segAddr - (segmentWordArray + self baseHeaderSize) / 4. self shorten: outPointerArray toIndexableSize: outIndex. ^self return: PrimNoErr restoringObjectsIn: arrayOfObjects savedFirstFields: savedFirstFields and: outPointerArray savedHashes: savedOutHashes! Item was changed: ----- Method: SpurPlanningCompactorTests>>checkForLeaksIn: (in category 'private') ----- checkForLeaksIn: om + om setCheckForLeaks: GCCheckFreeSpace + GCModeFull; - om setCheckForLeaks: GCModeFreeSpace + GCModeFull; runLeakCheckerFor: GCModeFull; checkFreeSpace: GCModeFull! Item was changed: ----- Method: SpurSegmentManager>>shrinkObjectMemory: (in category 'growing/shrinking memory') ----- shrinkObjectMemory: delta "Answer if any shrinkage was achieved." <inline: false> <var: #delta type: #usqInt> | shrinkage emptySeg | <var: #shrinkage type: #usqInt> <var: #emptySeg type: #'SpurSegmentInfo *'> + manager checkFreeSpace: GCCheckFreeSpace. - manager checkFreeSpace: GCModeFreeSpace. shrinkage := delta. [emptySeg := self findEmptySegNearestInSizeTo: shrinkage. (emptySeg isNil or: [emptySeg segSize > shrinkage]) ifTrue: + [manager checkFreeSpace: GCCheckFreeSpace. - [manager checkFreeSpace: GCModeFreeSpace. ^shrinkage < delta]. shrinkage := shrinkage - emptySeg segSize. manager detachFreeObject: (manager objectStartingAt: emptySeg segStart). self removeSegment: emptySeg] repeat! Item was changed: ----- Method: SpurSelectiveCompactorSimulator>>compact (in category 'api') ----- compact self talk: '~~ Start selective compaction ~~'. self tellMeNumSegmentAndTotalFreeSpace. self tellMeWhichSegmentsAreBeingCompacted. super compact. self tellMeNumSegmentAndTotalFreeSpace. self tellMeWhichSegmentsAreBeingCompacted. + manager runLeakCheckerForFreeSpace: GCCheckFreeSpace ignoring: nil. - manager runLeakCheckerForFreeSpace: GCModeFreeSpace ignoring: nil. self talk: '~~ Finished selective compaction ~~'. ! Item was changed: ----- Method: StackInterpreter class>>initializeMiscConstants (in category 'initialization') ----- initializeMiscConstants super initializeMiscConstants. STACKVM := true. + "These flags identify a GC operation (& hence a reason to leak check), + or just operations the leak checker can be run for." - "These flags function to identify a GC operation, or - to specify what operations the leak checker should be run for." GCModeFull := 1. "stop-the-world global GC" GCModeNewSpace := 2. "Spur's scavenge, or V3's incremental" GCModeIncremental := 4. "incremental global gc (Dijkstra tri-colour marking); as yet unimplemented" GCModeBecome := 8. "v3 post-become sweeping/Spur forwarding" + GCCheckImageSegment := 16. "just a flag for leak checking image segments" + GCCheckFreeSpace := 32. "just a flag for leak checking free space; Spur only" + GCCheckShorten := 64. "just a flag for leak checking object shortening operations; Spur only" + GCCheckPrimCall := 128. "just a flag for leak checking external primitive calls" - GCModeImageSegment := 16. "just a flag for leak checking image segments" - GCModeFreeSpace := 32. "just a flag for leak checking free space; Spur only" - GCCheckPrimCall := 64. "just a flag for leak checking external primitive calls" StackPageTraceInvalid := -1. StackPageUnreached := 0. StackPageReachedButUntraced := 1. StackPageTraced := 2. DumpStackOnLowSpace := 0. MillisecondClockMask := 16r1FFFFFFF. "Note: The external primitive table should actually be dynamically sized but for the sake of inferior platforms (e.g., Mac :-) who cannot allocate memory in any reasonable way, we keep it static (and cross our fingers...)" MaxExternalPrimitiveTableSize := 4096. "entries" MaxJumpBuf := 32. "max. callback depth" FailImbalancedPrimitives := InitializationOptions at: #FailImbalancedPrimitives ifAbsentPut: [true]. EnforceAccessControl := InitializationOptions at: #EnforceAccessControl ifAbsent: [true]. ReturnToInterpreter := 1. "setjmp/longjmp code." "Because of a hack with callbacks in the non-threaded VM they must not conflct with the VM's tag bits." DisownVMForFFICall := 16. DisownVMForThreading := 32 ! Item was changed: ----- Method: StackInterpreterSimulator>>cloneSimulation (in category 'debug support') ----- cloneSimulation | savedAtEachStepBlock savedDisplayView savedDisplayForm savedQuitBlock savedTranscript | savedAtEachStepBlock := atEachStepBlock. atEachStepBlock := nil. savedDisplayView := displayView. displayView := nil. savedDisplayForm := displayForm. displayForm = nil. savedQuitBlock := quitBlock. quitBlock := nil. savedTranscript := transcript. transcript := nil. ^[| theClone | + self changed: #byteCountText. Smalltalk garbageCollect. theClone := self veryDeepCopy. theClone parent: self; transcript: Transcript. theClone objectMemory parent: objectMemory. theClone] ensure: [atEachStepBlock := savedAtEachStepBlock. displayView := savedDisplayView. displayForm = savedDisplayForm. quitBlock := savedQuitBlock. transcript := savedTranscript]! Item was changed: SharedPool subclass: #VMBasicConstants instanceVariableNames: '' + classVariableNames: 'BaseHeaderSize BytecodeSetHasExtensions BytesPerOop BytesPerWord COGMTVM COGVM CloneOnGC CloneOnScavenge DisownVMForFFICall DisownVMForThreading DoAssertionChecks DoExpensiveAssertionChecks GCCheckFreeSpace GCCheckImageSegment GCCheckPrimCall GCCheckShorten GCModeBecome GCModeFull GCModeIncremental GCModeNewSpace HashMultiplyConstant HashMultiplyMask IMMUTABILITY LowcodeVM MULTIPLEBYTECODESETS NewspeakVM PharoVM PrimErrBadArgument PrimErrBadIndex PrimErrBadMethod PrimErrBadNumArgs PrimErrBadReceiver PrimErrCallbackError PrimErrFFIException PrimErrGenericFailure PrimErrInappropriate PrimErrInternalError PrimErrLimitExceeded PrimErrNamedInternal PrimErrNeedCompaction PrimErrNoCMemory PrimErrNoMemory PrimErrNoModification PrimErrNotFound PrimErrOSError PrimErrObjectIsPinned PrimErrObjectMayMove PrimErrObjectMoved PrimErrObjectNotPinned PrimErrOperationFailed PrimErrUninitialized PrimErrUnsupported PrimErrWritePastObject PrimNoErr PrimNumberHandlerMarker PrimNumbe rNoContextSwitchMarker PrimNumberUnwindMarker SPURVM STACKVM SistaVM TempVectReadBarrier VMBIGENDIAN' - classVariableNames: 'BaseHeaderSize BytecodeSetHasExtensions BytesPerOop BytesPerWord COGMTVM COGVM CloneOnGC CloneOnScavenge DisownVMForFFICall DisownVMForThreading DoAssertionChecks DoExpensiveAssertionChecks GCCheckPrimCall GCModeBecome GCModeFreeSpace GCModeFull GCModeImageSegment GCModeIncremental GCModeNewSpace HashMultiplyConstant HashMultiplyMask IMMUTABILITY LowcodeVM MULTIPLEBYTECODESETS NewspeakVM PharoVM PrimErrBadArgument PrimErrBadIndex PrimErrBadMethod PrimErrBadNumArgs PrimErrBadReceiver PrimErrCallbackError PrimErrFFIException PrimErrGenericFailure PrimErrInappropriate PrimErrInternalError PrimErrLimitExceeded PrimErrNamedInternal PrimErrNeedCompaction PrimErrNoCMemory PrimErrNoMemory PrimErrNoModification PrimErrNotFound PrimErrOSError PrimErrObjectIsPinned PrimErrObjectMayMove PrimErrObjectMoved PrimErrObjectNotPinned PrimErrOperationFailed PrimErrUninitialized PrimErrUnsupported PrimErrWritePastObject PrimNoErr PrimNumberHandlerMarker PrimNumberNoContextSwitchM arker PrimNumberUnwindMarker SPURVM STACKVM SistaVM TempVectReadBarrier VMBIGENDIAN' poolDictionaries: '' category: 'VMMaker-Interpreter'! !VMBasicConstants commentStamp: '<historical>' prior: 0! I am a shared pool for basic constants upon which the VM as a whole depends. self ensureClassPool. self classPool declare: #BytesPerWord from: VMSqueakV3ObjectRepresentationConstants classPool. self classPool declare: #BaseHeaderSize from: VMSqueakV3ObjectRepresentationConstants classPool (ObjectMemory classPool keys select: [:k| k beginsWith: 'Byte']) do: [:k| self classPool declare: k from: ObjectMemory classPool]! Item was changed: ----- Method: VMBasicConstants class>>namesDefinedAtCompileTime (in category 'C translation') ----- namesDefinedAtCompileTime "Answer the set of names for variables that should be defined at compile time. Some of these get default values during simulation, and hence get defaulted in the various initializeMiscConstants methods. But that they have values should /not/ cause the code generator to do dead code elimination based on their default values. In particular, methods marked with <option: ANameDefinedAtCompileTime> will be emitted within #if defined(ANameDefinedAtCompileTime)...#endif. And of course this is backwards. We'd like to define names that are defined at translation time." ^#(VMBIGENDIAN IMMUTABILITY STACKVM COGVM COGMTVM SPURVM PharoVM "Pharo vs Squeak" TerfVM VM_TICKER "Terf vs Squeak & Qwaq/Teleplace/Terf high-priority thread support" EnforceAccessControl "Newspeak" CheckRememberedInTrampoline "IMMUTABILITY" BIT_IDENTICAL_FLOATING_POINT PLATFORM_SPECIFIC_FLOATING_POINT "Alternatives for using fdlibm for floating-point" + TestingPrimitives OBSOLETE_ALIEN_PRIMITIVES "Ancient crap in the IA32ABI plugin" LLDB "As of lldb-370.0.42 Swift-3.1, passing function parameters to printOopsSuchThat fails with Internal error [IRForTarget]: Couldn't rewrite one of the arguments of a function call. Turning off link time optimization with -fno-lto has no effect. hence we define some debugging functions as being <option: LLDB>" "processor related" __ARM_ARCH__ __arm__ __arm32__ ARM32 __arm64__ ARM64 _M_I386 _X86_ i386 i486 i586 i686 __i386__ __386__ X86 I386 x86_64 __amd64 __x86_64 __amd64__ __x86_64__ _M_AMD64 _M_X64 __mips__ __mips __powerpc __powerpc__ __powerpc64__ __POWERPC__ __ppc__ __ppc64__ __PPC__ __PPC64__ __sparc__ __sparc __sparc_v8__ __sparc_v9__ __sparcv8 __sparcv9 "Compiler brand related" __ACK__ __CC_ARM __clang__ __GNUC__ _MSC_VER __ICC __SUNPRO_C "os related" ACORN _AIX __ANDROID__ __BEOS__ __linux__ __MINGW32__ __FreeBSD__ __NetBSD__ __OpenBSD__ __osf__ EPLAN9 __unix__ __unix UNIX WIN32 _WIN32 _WIN32_WCE WIN64 _WIN64 _WIN64_WCE)! Item was added: + ----- Method: VMClass>>assertf: (in category 'simulation support') ----- + assertf: aString + <doNotGenerate> + AssertionFailure signal: 'Assertion failed: ', aString!

1 0

VM Maker: VMMakerUI-eem.37.mcz
by commits＠source.squeak.org 23 Jun '21

23 Jun '21

Eliot Miranda uploaded a new version of VMMakerUI to project VM Maker: http://source.squeak.org/VMMaker/VMMakerUI-eem.37.mcz ==================== Summary ==================== Name: VMMakerUI-eem.37 Author: eem Time: 22 June 2021, 3:01:24.300424 pm UUID: 2a363fe6-bb8f-4817-a0de-5dba9bb773fd Ancestors: VMMakerUI-eem.36 Robustess prior to display installation in the simulators' handleListenEvent:s =============== Diff against VMMakerUI-eem.36 =============== Item was changed: ----- Method: CogVMSimulator>>handleListenEvent: (in category '*VMMakerUI-I/O primitive support') ----- handleListenEvent: aMorphicEvent "openAsMorph[NoTranscript] registered me for listen events via HandMorph>>addEventListener. + Transform the listen event and add it to my event queue. Also check if the displayForm should resize." + (displayForm notNil and: [displayForm ~~ fakeForm and: [displayForm extent ~= displayView extent]]) ifTrue: - Transform the listen event and add it to my event queue. ALso check if the displayForm should resize." - (displayForm ~~ fakeForm and: [displayForm extent ~= displayView extent]) ifTrue: [| newForm | newForm := Form extent: displayView extent depth: displayForm depth. displayForm displayOn: newForm. displayForm := newForm. displayView image: displayForm]. ((aMorphicEvent isMouse or: [aMorphicEvent isKeyboard]) and: [displayView bounds containsPoint: aMorphicEvent position]) ifTrue: [[eventTransformer degenerateEvent: aMorphicEvent for: self] on: Error do: [:ex| displayView activeHand removeEventListener: self. ex pass]]! Item was changed: ----- Method: StackInterpreterSimulator>>handleListenEvent: (in category '*VMMakerUI-I/O primitive support') ----- handleListenEvent: aMorphicEvent "openAsMorph[NoTranscript] registered me for listen events via HandMorph>>addEventListener. + Transform the listen event and add it to my event queue. Also check if the displayForm should resize." + (displayForm notNil and: [displayForm ~~ fakeForm and: [displayForm extent ~= displayView extent]]) ifTrue: - Transform the listen event and add it to my event queue. ALso check if the displayForm should resize." - (displayForm ~~ fakeForm and: [displayForm extent ~= displayView extent]) ifTrue: [| newForm | newForm := Form extent: displayView extent depth: displayForm depth. displayForm displayOn: newForm. displayForm := newForm. displayView image: displayForm]. ((aMorphicEvent isMouse or: [aMorphicEvent isKeyboard]) and: [displayView bounds containsPoint: aMorphicEvent position]) ifTrue: [[eventTransformer degenerateEvent: aMorphicEvent for: self] on: Error do: [:ex| displayView activeHand removeEventListener: self. ex pass]]! Item was changed: ----- Method: StackInterpreterSimulator>>openAsMorph (in category '*VMMakerUI-InterpreterSimulation-Morphic') ----- openAsMorph "Open a morphic view on this simulation." | localImageName borderWidth window | localImageName := imageName ifNotNil: [self localNameFor: imageName] ifNil: [' synthetic image']. window := (SystemWindow labelled: 'Simulation of ', localImageName) model: self. window paneColor: self windowColorToUse. window addMorph: (displayView := SimulatorImageMorph new image: displayForm) frame: (0@0 corner: 1(a)0.8). displayView activeHand addEventListener: self. eventTransformer := SimulatorEventTransformer new. transcript := TranscriptStream on: (String new: 10000). window addMorph: (PluggableTextMorph on: transcript text: nil accept: nil readSelection: nil menu: #codePaneMenu:shifted:) frame: (0(a)0.8 corner: 0.7@1). window addMorph: (PluggableTextMorph on: self text: #byteCountText accept: nil readSelection: nil menu: #utilitiesMenu:) hideScrollBarsIndefinitely frame: (0.7(a)0.8 corner: 1@1). borderWidth := [SystemWindow borderWidth] "Squeak 4.1" on: MessageNotUnderstood do: [:ex| 0]. "3.8" borderWidth := borderWidth + window borderWidth. window openInWorldExtent: (self desiredDisplayExtent + + (2 * borderWidth @ borderWidth) - + (2 * borderWidth@borderWidth) + (0@window labelHeight) * (1(a)(1/0.8))) rounded. ^window!

1 0

VM Maker: Cog-eem.436.mcz
by commits＠source.squeak.org 23 Jun '21

23 Jun '21

Eliot Miranda uploaded a new version of Cog to project VM Maker: http://source.squeak.org/VMMaker/Cog-eem.436.mcz ==================== Summary ==================== Name: Cog-eem.436 Author: eem Time: 22 June 2021, 3:00:00.075766 pm UUID: 644192a7-a217-4644-917e-497129b8824d Ancestors: Cog-eem.435 Image level tests for Spur shorten:toIndexableSize: =============== Diff against Cog-eem.435 =============== Item was added: + ----- Method: CogVMTests>>primitiveShorten:to: (in category 'support') ----- + primitiveShorten: anObject to: indexableSize + <primitive: #primitiveTestShortenIndexableSize module: '' error: ec> + self primitiveFailed! Item was added: + ----- Method: CogVMTests>>testShorten (in category 'tests') ----- + testShorten + "The VM requires shortening for ImageSegment load and for Sista introspection. + It uses these facilities on WordArrays (ImageSegment) and Array (Sista) only. + Test that both objects in newSpace and oldSpace can be shortened successfully. + Note that implicitly this tests issues to do with object enumeraiton and slimbridges + in the VM, i.e. this test is most usefully run in an image running on the simulator." + + { WordArray. Array } do: + [:class| + (1 to: 8), (1024 to: 1032) do: "1 to: 8 for no overflow header, 1024 to: 1032 for overflow header" + [:s| + {s. s - 1. s - 2. s // 2. 1. 2. 4 } do: + [:delta| | newArray oldArray | + (delta between: 1 and: s) ifTrue: + [newArray := class new: s. + self primitiveShorten: newArray to: s - delta. + self assert: s - delta equals: newArray size. + oldArray := class new: s. + oldArray pin; unpin. "Move to oldSpace" + self primitiveShorten: oldArray to: s - delta. + self assert: s - delta equals: oldArray size]]]] + + "self new testShorten" + + "(FileStream oldFileNamed: 'CogVMTests-shorten.st') fileIn. CogVMTests new testShorten!!"!

1 0

Re: [Vm-dev] [OpenSmalltalk/opensmalltalk-vm] CogVM source as per VMMaker.oscog-eem.2970 (b0fc229)
by smalltalking 21 Jun '21

21 Jun '21

Hi Eliot, There seems to be an extra double quote there before TEXT, which prevents the compilation of this file. -- You are receiving this because you are subscribed to this thread. Reply to this email directly or view it on GitHub: https://github.com/OpenSmalltalk/opensmalltalk-vm/commit/b0fc22902a86197a31…

1 0

Build failed: opensmalltalk-vm 1.0.2457
by AppVeyor 21 Jun '21

21 Jun '21

1 0

[OpenSmalltalk/opensmalltalk-vm] a4b7c6: CogVM source as per VMMaker.oscog-eem.2971
by Eliot Miranda 21 Jun '21

21 Jun '21

Branch: refs/heads/Cog Home: https://github.com/OpenSmalltalk/opensmalltalk-vm Commit: a4b7c6ae4c55e7acc56245cc13b722bba246da46 https://github.com/OpenSmalltalk/opensmalltalk-vm/commit/a4b7c6ae4c55e7acc5… Author: Eliot Miranda <eliot.miranda(a)gmail.com> Date: 2021-06-20 (Sun, 20 Jun 2021) Changed paths: M spur64src/vm/cogit.h M spur64src/vm/cointerp.c M spur64src/vm/cointerp.h M spur64src/vm/cointerpmt.c M spur64src/vm/cointerpmt.h M spur64src/vm/gcc3x-cointerp.c M spur64src/vm/gcc3x-cointerpmt.c M spurlowcode64src/vm/cogit.h M spurlowcode64src/vm/cointerp.c M spurlowcode64src/vm/cointerp.h M spurlowcode64src/vm/gcc3x-cointerp.c M spurlowcodesrc/vm/cogit.h M spurlowcodesrc/vm/cointerp.c M spurlowcodesrc/vm/cointerp.h M spurlowcodesrc/vm/gcc3x-cointerp.c M spurlowcodestack64src/vm/gcc3x-interp.c M spurlowcodestack64src/vm/interp.c M spurlowcodestacksrc/vm/gcc3x-interp.c M spurlowcodestacksrc/vm/interp.c M spursista64src/vm/cogit.h M spursista64src/vm/cointerp.c M spursista64src/vm/cointerp.h M spursista64src/vm/gcc3x-cointerp.c M spursistasrc/vm/cogit.h M spursistasrc/vm/cointerp.c M spursistasrc/vm/cointerp.h M spursistasrc/vm/gcc3x-cointerp.c M spursrc/vm/cogit.h M spursrc/vm/cointerp.c M spursrc/vm/cointerp.h M spursrc/vm/cointerpmt.c M spursrc/vm/cointerpmt.h M spursrc/vm/gcc3x-cointerp.c M spursrc/vm/gcc3x-cointerpmt.c M spurstack64src/vm/gcc3x-interp.c M spurstack64src/vm/interp.c M spurstack64src/vm/validImage.c M spurstacksrc/vm/gcc3x-interp.c M spurstacksrc/vm/interp.c M spurstacksrc/vm/validImage.c M src/vm/cogit.h Log Message: ----------- CogVM source as per VMMaker.oscog-eem.2971 Spur Image segment loading creates objects that are ambiguous with newspace slimbridges. Beef up slimbridge parsing (objectAfterMaybeSlimBridge:limit:) so that objects in oldSpace are not confused with them. [the shim idea will need to be thought through carefully wrt shortening objects]

1 0

VM Maker: VMMaker.oscog-eem.2971.mcz
by commits＠source.squeak.org 21 Jun '21

21 Jun '21

Eliot Miranda uploaded a new version of VMMaker to project VM Maker: http://source.squeak.org/VMMaker/VMMaker.oscog-eem.2971.mcz ==================== Summary ==================== Name: VMMaker.oscog-eem.2971 Author: eem Time: 20 June 2021, 10:20:32.415024 pm UUID: b9251568-d992-439d-a42e-846c5acbf5fd Ancestors: VMMaker.oscog-eem.2970 Image segment loading creates objects that are ambiguous with newspace slimbridges. Beef up slimbridge parsing (objectAfterMaybeSlimBridge:limit:) so that objects in oldSpace are not confused with them. [the shim idea will need to be thought through carefully w.r.t. shortening objects] =============== Diff against VMMaker.oscog-eem.2970 =============== Item was changed: ----- Method: Spur32BitMemoryManager>>objectAfterMaybeSlimBridge:limit: (in category 'object enumeration-private') ----- objectAfterMaybeSlimBridge: objOop limit: limit "Object parsing. 1. all objects have at least a word following the header, for a forwarding pointer. 2. objects with an overflow size have a preceding word with a saturated numSlots. If the word following an object doesn't have a saturated numSlots field it must be a single-header object. If the word following does have a saturated numSlots it must be the overflow size word. This variation on objectAfter:limit: allows for a single (64-bit) word bridge which may be needed to bridge from an almost full pastSpace to eden. It is only used in the flat enumerators that use startAddressForBridgedHeapEnumeration and enumerate over pastSpace, eden and oldSpace in that order. Note that the order for allObjects, and allInstances enumerates over oldSpace first. This hack is cheap. It increases the size of the objectAfter code, but saves two extra copies of the inner loop, since the inner loop now enumerates over all of pastSpace, eden and oldSpace. The test for a slim bridge is only performed if applied to an overflow header, and typically only + 1 in 400 objects have overflow headers in 32-bits, 1 in 500 in 64-bits. The complication is that + image segment loading evaporates the word array by setting the overflow slots to 1, and this + is ambiguous with a slimbridge. The resolution is that slimbridges are used only in new space." - 1 in 400 objects have overflow headers in 32-bits, 1 in 500 in 64-bits." <inline: true> | followingWordAddress followingWord | followingWordAddress := self addressAfter: objOop. (self oop: followingWordAddress isGreaterThanOrEqualTo: limit) ifTrue: [^limit]. self flag: #endianness. followingWord := self longAt: followingWordAddress + 4. ^followingWord >> self numSlotsHalfShift = self numSlotsMask + ifTrue: [((self oop: objOop isGreaterThanOrEqualTo: oldSpaceStart) + and: [1 = (self longAt: followingWordAddress)]) "i.e. the raw overflow slots in the overflow word" - ifTrue: [1 = (self longAt: followingWordAddress) "i.e. the raw overflow slots in the overflow word" ifTrue: [followingWordAddress + self baseHeaderSize + self baseHeaderSize] ifFalse: [followingWordAddress + self baseHeaderSize]] ifFalse: [followingWordAddress]! Item was changed: ----- Method: Spur32BitMemoryManager>>rawOverflowSlotsOf:put: (in category 'object access') ----- rawOverflowSlotsOf: objOop put: numSlots <returnTypeC: #usqInt> <inline: true> self flag: #endianness. + self deny: (numSlots = 1 and: [self oop: objOop isLessThan: newSpaceLimit]). "otherwise ambiguous with a slimbridge" ^self longAt: objOop - self baseHeaderSize put: numSlots! Item was changed: ----- Method: Spur64BitMemoryManager>>objectAfterMaybeSlimBridge:limit: (in category 'object enumeration-private') ----- objectAfterMaybeSlimBridge: objOop limit: limit "Object parsing. 1. all objects have at least a word following the header, for a forwarding pointer. 2. objects with an overflow size have a preceding word with a saturated numSlots. If the word following an object doesn't have a saturated numSlots field it must be a single-header object. If the word following does have a saturated numSlots it must be the overflow size word. This variation on objectAfter:limit: allows for a single (64-bit) word bridge which may be needed to bridge from an almost full pastSpace to eden. It is only used in the flat enumerators that use startAddressForBridgedHeapEnumeration and enumerate over pastSpace, eden and oldSpace in that order. Note that the order for allObjects, and allInstances enumerates over oldSpace first. This hack is cheap. It increases the size of the objectAfter code, but saves two extra copies of the inner loop, since the inner loop now enumerates over all of pastSpace, eden and oldSpace. The test for a slim bridge is only performed if applied to an overflow header, and typically only + 1 in 400 objects have overflow headers in 32-bits, 1 in 500 in 64-bits. The complication is that + image segment loading evaporates the word array by setting the overflow slots to 1, and this + is ambiguous with a slimbridge. The resolution is that slimbridges are used only in new space." - 1 in 400 objects have overflow headers in 32-bits, 1 in 500 in 64-bits." <inline: true> | followingWordAddress followingWord | followingWordAddress := self addressAfter: objOop. (self oop: followingWordAddress isGreaterThanOrEqualTo: limit) ifTrue: [^limit]. self flag: #endianness. followingWord := self longAt: followingWordAddress. ^followingWord >> self numSlotsFullShift = self numSlotsMask ifTrue: + [((self oop: objOop isGreaterThanOrEqualTo: oldSpaceStart) + and: [(followingWord bitAnd: 16rFFFFFFFFFFFFFF) = 1]) - [(followingWord bitAnd: 16rFFFFFFFFFFFFFF) = 1 ifTrue: [followingWordAddress + self baseHeaderSize + self baseHeaderSize] ifFalse: [followingWordAddress + self baseHeaderSize]] ifFalse: [followingWordAddress]! Item was changed: ----- Method: Spur64BitMemoryManager>>rawOverflowSlotsOf:put: (in category 'object access') ----- rawOverflowSlotsOf: objOop put: numSlots <returnTypeC: #usqLong> <inline: true> self flag: #endianness. + self deny: (numSlots = 1 and: [self oop: objOop isLessThan: newSpaceLimit]). "otherwise ambiguous with a slimbridge" self longAt: objOop - self baseHeaderSize put: self numSlotsMask << 56 + numSlots. ^numSlots!

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

Vm-dev June 2021