[Vm-dev] VM Maker: VMMaker.oscog-eem.2973.mcz
commits at source.squeak.org
commits at source.squeak.org
Tue Jun 22 22:35:32 UTC 2021
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!
More information about the Vm-dev
mailing list