[Vm-dev] VM Maker: VMMaker.oscog-eem.479.mcz
commits at source.squeak.org
commits at source.squeak.org
Sat Oct 26 04:26:42 UTC 2013
Eliot Miranda uploaded a new version of VMMaker to project VM Maker:
http://source.squeak.org/VMMaker/VMMaker.oscog-eem.479.mcz
==================== Summary ====================
Name: VMMaker.oscog-eem.479
Author: eem
Time: 25 October 2013, 9:22:02.442 pm
UUID: fa519ded-1bce-42c3-87b0-3cd3b14c1dd8
Ancestors: VMMaker.oscog-eem.478
Fix bugs in allocateOldSpaceChunkOfBytes: &
allocateOldSpaceChunkOfBytes:suchThat: (incorrect freeListsMask
maintennance).
Make sure eliminateAndFreeForwarders follows specialObjectsOop.
Fix slips in sortFreeListAt: & unlinkSolitaryFreeTreeNode:
(ofObject: => ofFreeChunk:).
markAndTraceStackPage: should use isImmediate: not isIntegerObject:
=============== Diff against VMMaker.oscog-eem.478 ===============
Item was changed:
----- Method: Spur32BitMMLESimulator>>isIntegerObject: (in category 'object testing') -----
isIntegerObject: oop
"This list records the valid senders of isIntegerObject: as we replace uses of
isIntegerObject: by isImmediate: where appropriate."
| sel |
sel := thisContext sender method selector.
(#( DoIt
DoItIn:
on:do: "from the debugger"
makeBaseFrameFor:
quickFetchInteger:ofObject:
frameOfMarriedContext:
objCouldBeClassObj:
isMarriedOrWidowedContext:
shortPrint:
bytecodePrimAt
bytecodePrimAtPut
commonAt:
commonAtPut:
loadFloatOrIntFrom:
positive32BitValueOf:
primitiveExternalCall
checkedIntegerValueOf:
bytecodePrimAtPut
commonAtPut:
primitiveVMParameter
checkIsStillMarriedContext:currentFP:
displayBitsOf:Left:Top:Right:Bottom:
fetchStackPointerOf:
primitiveContextAt
primitiveContextAtPut
subscript:with:storing:format:
printContext:
compare31or32Bits:equal:
signed64BitValueOf:
primDigitMultiply:negative:
digitLength:
isNegativeIntegerValueOf:
magnitude64BitValueOf:
primitiveMakePoint
primitiveAsCharacter
primitiveInputSemaphore
baseFrameReturn
primitiveExternalCall
primDigitCompare:
isLiveContext:
numPointerSlotsOf:
fileValueOf:
loadBitBltDestForm
fetchIntOrFloat:ofObject:ifNil:
fetchIntOrFloat:ofObject:
loadBitBltSourceForm
loadPoint:from:
primDigitAdd:
primDigitSubtract:
positive64BitValueOf:
digitBitLogic:with:opIndex:
signed32BitValueOf:
isNormalized:
primDigitDiv:negative:
bytesOrInt:growTo:
primitiveNewMethod
isCogMethodReference:
functionForPrimitiveExternalCall:
genSpecialSelectorArithmetic
genSpecialSelectorComparison
ensureContextHasBytecodePC:
instVar:ofContext:
ceBaseFrameReturn:
inlineCacheTagForInstance:
primitiveObjectAtPut
commonVariable:at:put:cacheIndex:
primDigitBitShiftMagnitude:
externalInstVar:ofContext:
+ primitiveGrowMemoryByAtLeast
+ primitiveFileSetPosition) includes: sel) ifFalse:
- primitiveGrowMemoryByAtLeast) includes: sel) ifFalse:
[self halt].
^super isIntegerObject: oop!
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: chunkBytes = (self bytesInObject: freeChunk).
self assert: chunkBytes / self allocationUnit >= self numFreeLists.
self
storePointer: self freeChunkNextIndex ofFreeChunk: freeChunk withValue: 0;
storePointer: self freeChunkParentIndex ofFreeChunk: freeChunk withValue: 0;
storePointer: self freeChunkSmallerIndex ofFreeChunk: freeChunk withValue: 0;
storePointer: self freeChunkLargerIndex ofFreeChunk: freeChunk withValue: 0.
"Large chunk list organized as a tree, each node of which is a list of chunks of the same size.
Beneath the node are smaller and larger blocks."
parent := 0.
child := freeLists at: 0.
[child ~= 0] whileTrue:
[childBytes := self bytesInObject: child.
childBytes = chunkBytes ifTrue: "size match; add to list at node."
[self storePointer: self freeChunkNextIndex
ofFreeChunk: freeChunk
withValue: (self fetchPointer: self freeChunkNextIndex ofObject: child);
storePointer: self freeChunkNextIndex
ofFreeChunk: child
withValue: freeChunk.
^child].
"walk down the tree"
parent := child.
child := self fetchPointer: (childBytes > chunkBytes
ifTrue: [self freeChunkSmallerIndex]
ifFalse: [self freeChunkLargerIndex])
ofObject: child].
parent = 0 ifTrue:
[self assert: (freeLists at: 0) = 0.
freeLists at: 0 put: freeChunk.
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>>allocateOldSpaceChunkOfBytes: (in category 'free space') -----
allocateOldSpaceChunkOfBytes: chunkBytes
"Answer a chunk of oldSpace from the free lists, if available,
otherwise answer nil. Break up a larger chunk if one of the
exact size does not exist. N.B. the chunk is simply a pointer, it
has no valid header. The caller *must* fill in the header correctly."
| initialIndex chunk index nodeBytes parent child |
"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 assert: (self isValidFreeObject: chunk).
^self unlinkFreeChunk: chunk atIndex: initialIndex].
freeListsMask := freeListsMask - (1 << initialIndex)].
"first search for free chunks of a multiple of chunkBytes in size"
index := initialIndex.
[(index := index + index) < self numFreeLists
and: [1 << index <= freeListsMask]] whileTrue:
+ [(freeListsMask anyMask: 1 << index) ifTrue:
+ [(chunk := freeLists at: index) ~= 0 ifTrue:
+ [self assert: chunk = (self startOfObject: chunk).
+ self assert: (self isValidFreeObject: chunk).
+ self unlinkFreeChunk: chunk atIndex: index.
+ self assert: (self bytesInObject: chunk) = (index * self allocationUnit).
+ self freeChunkWithBytes: index * self allocationUnit - chunkBytes
+ at: (self startOfObject: chunk) + chunkBytes.
+ ^chunk].
+ freeListsMask := freeListsMask - (1 << index)]].
- [((freeListsMask anyMask: 1 << index)
- and: [(chunk := freeLists at: index) ~= 0]) ifTrue:
- [self assert: chunk = (self startOfObject: chunk).
- self assert: (self isValidFreeObject: chunk).
- self unlinkFreeChunk: chunk atIndex: index.
- self assert: (self bytesInObject: chunk) = (index * self allocationUnit).
- self freeChunkWithBytes: index * self allocationUnit - chunkBytes
- at: (self startOfObject: chunk) + chunkBytes.
- ^chunk]].
"now get desperate and use the first that'll fit.
Note that because the minimum free size is 16 bytes (2 * allocationUnit), to
leave room for the forwarding pointer/next free link, we can only break chunks
that are at least 16 bytes larger, hence start at initialIndex + 2."
index := initialIndex + 1.
[(index := index + 1) < self numFreeLists
and: [1 << index <= freeListsMask]] whileTrue:
[(freeListsMask anyMask: 1 << index) ifTrue:
[(chunk := freeLists at: index) ~= 0 ifTrue:
[self assert: chunk = (self startOfObject: chunk).
self assert: (self isValidFreeObject: chunk).
self unlinkFreeChunk: chunk atIndex: index.
self assert: (self bytesInObject: chunk) = (index * self allocationUnit).
self freeChunkWithBytes: index * self allocationUnit - chunkBytes
at: (self startOfObject: chunk) + chunkBytes.
^chunk].
freeListsMask := freeListsMask - (1 << index)]]].
"Large chunk, or no space on small free lists. Search the large chunk list.
Large chunk list organized as a tree, each node of which is a list of chunks
of the same size. Beneath the node are smaller and larger blocks.
When the search ends parent should hold the smallest chunk at least as
large as chunkBytes, or 0 if none."
parent := 0.
child := freeLists at: 0.
[child ~= 0] whileTrue:
[| childBytes |
self assert: (self isValidFreeObject: child).
childBytes := self bytesInObject: child.
childBytes = chunkBytes
ifTrue: "size match; try to remove from list at node."
[chunk := self fetchPointer: self freeChunkNextIndex
ofFreeChunk: child.
chunk ~= 0 ifTrue:
[self assert: (self isValidFreeObject: chunk).
self storePointer: self freeChunkNextIndex
ofFreeChunk: child
withValue: (self fetchPointer: self freeChunkNextIndex
ofFreeChunk: chunk).
^self startOfObject: chunk].
child := 0] "break out of loop to remove interior node"
ifFalse:
["Note that because the minimum free size is 16 bytes (2 * allocationUnit), to
leave room for the forwarding pointer/next free link, we can only break chunks
that are at least 16 bytes larger, hence reject chunks < 2 * allocationUnit larger."
childBytes <= (chunkBytes + self allocationUnit)
ifTrue: "node too small; walk down the larger size of the tree"
[child := self fetchPointer: self freeChunkLargerIndex ofFreeChunk: child]
ifFalse:
[parent := child. "parent will be smallest node >= chunkBytes + allocationUnit"
nodeBytes := childBytes.
child := self fetchPointer: self freeChunkSmallerIndex ofFreeChunk: child]]].
parent = 0 ifTrue:
[totalFreeOldSpace := totalFreeOldSpace + chunkBytes. "optimism was unfounded"
^nil].
"self printFreeChunk: parent"
self assert: (nodeBytes = chunkBytes or: [nodeBytes >= (chunkBytes + (2 * self allocationUnit))]).
self assert: (self bytesInObject: parent) = nodeBytes.
"attempt to remove from list"
chunk := self fetchPointer: self freeChunkNextIndex ofFreeChunk: parent.
chunk ~= 0 ifTrue:
[self assert: (chunkBytes = nodeBytes or: [chunkBytes + self allocationUnit < nodeBytes]).
self storePointer: self freeChunkNextIndex
ofFreeChunk: parent
withValue: (self fetchPointer: self freeChunkNextIndex
ofFreeChunk: chunk).
chunkBytes ~= nodeBytes ifTrue:
[self freeChunkWithBytes: nodeBytes - chunkBytes
at: (self startOfObject: chunk) + chunkBytes].
^self startOfObject: chunk].
"no list; remove 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."
| initialIndex node next prev index child 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)]
- ifTrue: [freeListsMask := freeListsMask - (1 << index)]
ifFalse:
[prev := 0.
[node ~= 0] whileTrue:
[self assert: node = (self startOfObject: node).
self assert: (self isValidFreeObject: node).
next := self fetchPointer: self freeChunkNextIndex ofFreeChunk: node.
(acceptanceBlock value: node) ifTrue:
[prev = 0
+ ifTrue: [freeLists at: initialIndex put: next]
- ifTrue: [freeLists at: index put: next]
ifFalse: [self storePointer: self freeChunkNextIndex ofFreeChunk: prev withValue: next].
^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 assert: (self isValidFreeObject: node).
next := self fetchPointer: self freeChunkNextIndex ofFreeChunk: node.
(acceptanceBlock value: node) ifTrue:
[prev = 0
ifTrue: [freeLists at: index put: next]
ifFalse: [self storePointer: self freeChunkNextIndex ofFreeChunk: prev withValue: next].
self freeChunkWithBytes: index * self allocationUnit - chunkBytes
at: (self startOfObject: node) + chunkBytes.
^node].
+ prev := node.
+ node := next]]]].
- node := next].
- self assert: node = (self startOfObject: node).
- self assert: (self isValidFreeObject: node).
- self unlinkFreeChunk: node atIndex: index.
- self assert: (self bytesInObject: node) = (index * self allocationUnit).
- self freeChunkWithBytes: index * self allocationUnit - chunkBytes
- at: (self startOfObject: node) + chunkBytes.
- ^node]]].
"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 assert: (self isValidFreeObject: node).
next := self fetchPointer: self freeChunkNextIndex ofFreeChunk: node.
(acceptanceBlock value: node) ifTrue:
[prev = 0
ifTrue: [freeLists at: index put: next]
ifFalse: [self storePointer: self freeChunkNextIndex ofFreeChunk: prev withValue: next].
self freeChunkWithBytes: index * self allocationUnit - chunkBytes
at: (self startOfObject: node) + chunkBytes.
^node].
+ prev := node.
+ node := next]]]]].
- node := next].
- self assert: node = (self startOfObject: node).
- self assert: (self isValidFreeObject: node).
- self unlinkFreeChunk: node atIndex: index.
- self assert: (self bytesInObject: node) = (index * self allocationUnit).
- self freeChunkWithBytes: index * self allocationUnit - chunkBytes
- at: (self startOfObject: node) + chunkBytes.
- ^node]]]].
"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.
+ acceptedChunk := acceptedNode := 0.
[child ~= 0] whileTrue:
[| childBytes |
self assert: (self isValidFreeObject: child).
childBytes := self bytesInObject: child.
childBytes = chunkBytes ifTrue: "size match; try to remove from list at node."
[node := child.
[prev := node.
node := self fetchPointer: self freeChunkNextIndex ofFreeChunk: node.
node ~= 0] whileTrue:
[(acceptanceBlock value: node) ifTrue:
[self assert: (self isValidFreeObject: node).
self storePointer: self freeChunkNextIndex
ofFreeChunk: prev
withValue: (self fetchPointer: self freeChunkNextIndex ofFreeChunk: node).
^self startOfObject: node]].
(acceptanceBlock value: node) ifTrue:
[node := child.
child := 0]]. "break out of loop to remove interior node"
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:
[acceptedNode = 0 ifTrue:
[acceptedChunk := child.
"first search the list."
[acceptedChunk := self fetchPointer: self freeChunkNextIndex
ofFreeChunk: acceptedChunk.
+ (acceptedChunk ~= 0 and: [acceptanceBlock value: acceptedChunk]) ifTrue:
+ [acceptedNode := child].
+ acceptedChunk ~= 0 and: [acceptedNode = 0]] whileTrue.
- acceptedChunk ~= 0 and: [acceptedNode = 0]] whileTrue:
- [(acceptanceBlock value: acceptedChunk) ifTrue:
- [acceptedNode := child].
"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: child]) ifTrue:
[acceptedNode := child]].
+ child := self fetchPointer: self freeChunkSmallerIndex ofFreeChunk: child]]].
- child := self fetchPointer: self freeChunkSmallerIndex ofFreeChunk: child]]]].
acceptedNode ~= 0 ifTrue:
[acceptedChunk ~= 0 ifTrue:
[self assert: (self bytesInObject: acceptedChunk) >= (chunkBytes + self allocationUnit).
[next := self fetchPointer: self freeChunkNextIndex ofFreeChunk: acceptedNode.
next ~= acceptedChunk] whileTrue:
[acceptedNode := next].
self storePointer: self freeChunkNextIndex
ofFreeChunk: acceptedNode
withValue: (self fetchPointer: self freeChunkNextIndex ofFreeChunk: acceptedChunk).
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 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>>allocateOldSpaceChunkOfExactlyBytes: (in category 'free space') -----
allocateOldSpaceChunkOfExactlyBytes: chunkBytes
"Answer a chunk of oldSpace from the free lists, if one of this size
is available, otherwise answer nil. N.B. the chunk is simply a pointer,
it has no valid header. The caller *must* fill in the header correctly."
| initialIndex node nodeBytes child |
"for debugging:" "totalFreeOldSpace := self totalFreeListBytes"
initialIndex := chunkBytes / self allocationUnit.
initialIndex < self numFreeLists ifTrue:
+ [1 << initialIndex <= freeListsMask ifTrue:
+ [(node := freeLists at: initialIndex) ~= 0 ifTrue:
+ [self assert: node = (self startOfObject: node).
+ self assert: (self isValidFreeObject: node).
+ totalFreeOldSpace := totalFreeOldSpace - chunkBytes.
+ ^self unlinkFreeChunk: node atIndex: initialIndex].
+ freeListsMask := freeListsMask - (1 << initialIndex)].
- [(1 << initialIndex <= freeListsMask
- and: [(node := freeLists at: initialIndex) ~= 0]) ifTrue:
- [self assert: node = (self startOfObject: node).
- self assert: (self isValidFreeObject: node).
- totalFreeOldSpace := totalFreeOldSpace - chunkBytes.
- ^self unlinkFreeChunk: node atIndex: initialIndex].
^nil].
"Large chunk. Search the large chunk list.
Large chunk list organized as a tree, each node of which is a list of
chunks of the same size. Beneath the node are smaller and larger
blocks. When the search ends parent should hold the first chunk of
the same size as chunkBytes, or 0 if none."
node := 0.
child := freeLists at: 0.
[child ~= 0] whileTrue:
[| childBytes |
self assert: (self isValidFreeObject: child).
childBytes := self bytesInObject: child.
childBytes = chunkBytes
ifTrue: "size match; try to remove from list at node."
[node := self fetchPointer: self freeChunkNextIndex
ofFreeChunk: child.
node ~= 0 ifTrue:
[self assert: (self isValidFreeObject: node).
self storePointer: self freeChunkNextIndex
ofFreeChunk: child
withValue: (self fetchPointer: self freeChunkNextIndex
ofFreeChunk: node).
totalFreeOldSpace := totalFreeOldSpace - chunkBytes.
^self startOfObject: node].
node := child.
nodeBytes := childBytes.
child := 0] "break out of loop to remove interior node"
ifFalse:
[childBytes < chunkBytes
ifTrue: "walk down the tree"
[child := self fetchPointer: self freeChunkLargerIndex ofFreeChunk: child]
ifFalse:
[nodeBytes := childBytes.
child := self fetchPointer: self freeChunkSmallerIndex ofFreeChunk: child]]].
"if no chunk, there was no exact fit"
node = 0 ifTrue:
[^nil].
"self printFreeChunk: parent"
self assert: nodeBytes = chunkBytes.
self assert: (self bytesInObject: node) = chunkBytes.
"can't be a list; would have removed and returned it above."
self assert: (self fetchPointer: self freeChunkNextIndex ofFreeChunk: node) = 0.
"no list; remove the interior node"
self unlinkSolitaryFreeTreeNode: node.
totalFreeOldSpace := totalFreeOldSpace - chunkBytes.
^self startOfObject: node!
Item was changed:
----- Method: SpurMemoryManager>>bestFitCompact (in category 'compaction') -----
bestFitCompact
"Compact all of memory using best-fit, assuming free space is sorted
and that the highest objects are recorded in highestObjects."
<returnTypeC: #void>
<inline: false>
| freePriorToExactFit |
+ self checkFreeSpace.
freePriorToExactFit := totalFreeOldSpace.
self exactFitCompact.
+ self checkFreeSpace.
highestObjects isEmpty ifTrue:
[^self]. "either no high objects, or no misfits."
statCompactPassCount := statCompactPassCount + 1.
highestObjects reverseDo:
[:o| | b |
self assert: ((self isForwarded: o) or: [self isPinned: o]) not.
b := self bytesInObject: o.
(self allocateOldSpaceChunkOfBytes: b suchThat: [:f| f < o]) ifNotNil:
[:f|
self mem: f
cp: o
y: ((self hasOverflowHeader: o)
ifTrue: [b - self baseHeaderSize]
ifFalse: [b]).
(self isRemembered: o) ifTrue:
[scavenger remember: f].
self forward: o to: f]].
+ self checkFreeSpace.
self allOldSpaceObjectsFrom: firstFreeChunk
do: [:o| | b |
((self isForwarded: o)
or: [self isPinned: o]) ifFalse:
[b := self bytesInObject: o.
(self allocateOldSpaceChunkOfBytes: b suchThat: [:f| f < o]) ifNotNil:
[:f|
self mem: f
cp: o
y: ((self hasOverflowHeader: o)
ifTrue: [b - self baseHeaderSize]
ifFalse: [b]).
(self isRemembered: o) ifTrue:
[scavenger remember: f].
self forward: o to: f]]].
+ self checkFreeSpace.
- self checkFreeSpace
self touch: freePriorToExactFit!
Item was changed:
----- Method: SpurMemoryManager>>eliminateAndFreeForwarders (in category 'gc - global') -----
eliminateAndFreeForwarders
"As the final phase of global garbage collect, sweep
the heap to follow forwarders, then free forwarders"
| lowestForwarded firstForwarded lastForwarded |
+ self assert: (self isForwarded: nilObj) not.
+ self assert: (self isForwarded: falseObj) not.
+ self assert: (self isForwarded: trueObj) not.
+ self assert: (self isForwarded: hiddenRootsObj) not.
+ (self isForwarded: specialObjectsOop) ifTrue:
+ [specialObjectsOop := self followForwarded: specialObjectsOop].
lowestForwarded := 0.
self allOldSpaceObjectsDo:
[:o|
(self isForwarded: o)
ifTrue:
[lowestForwarded = 0 ifTrue:
[lowestForwarded := o]]
ifFalse:
[0 to: (self numPointerSlotsOf: o) - 1 do:
[:i| | f |
f := self fetchPointer: i ofObject: o.
(self isOopForwarded: f) ifTrue:
[f := self followForwarded: f.
self assert: ((self isImmediate: f) or: [self isYoung: f]) not.
self storePointerUnchecked: i ofObject: o withValue: f]]]].
firstForwarded := lastForwarded := 0.
self allOldSpaceObjectsFrom: lowestForwarded do:
[:o|
(self isForwarded: o)
ifTrue:
[firstForwarded = 0 ifTrue:
[firstForwarded := o].
lastForwarded := o]
ifFalse:
[firstForwarded ~= 0 ifTrue:
[| start bytes |
start := self startOfObject: firstForwarded.
bytes := (self addressAfter: lastForwarded) - start.
self addFreeChunkWithBytes: bytes at: start].
firstForwarded := 0]]!
Item was changed:
----- Method: SpurMemoryManager>>ensureAllMarkBitsAreZero (in category 'gc - incremental') -----
ensureAllMarkBitsAreZero
"If the incremental collector is running mark bits may be set; stop it and clear them if necessary."
+ self flag: 'need to implement the inc GC first...'!
- self shouldBeImplemented!
Item was changed:
----- Method: SpurMemoryManager>>fullGC (in category 'gc - global') -----
fullGC
+ <inline: false>
needGCFlag := false.
gcStartUsecs := self ioUTCMicrosecondsNow.
statMarkCount := 0.
+ coInterpreter preGCAction: GCModeFull.
- self preGCAction: GCModeFull.
self globalGarbageCollect.
+ coInterpreter postGCAction: GCModeFull.
- self postGCAction: GCModeFull.
statFullGCs := statFullGCs + 1.
statGCEndUsecs := self ioUTCMicrosecondsNow.
statFullGCUsecs := statFullGCUsecs + (statGCEndUsecs - gcStartUsecs).!
Item was added:
+ ----- Method: SpurMemoryManager>>ioUTCMicrosecondsNow (in category 'simulation only') -----
+ ioUTCMicrosecondsNow
+ "hack around the CoInterpreter/ObjectMemory split refactoring"
+ <doNotGenerate>
+ ^coInterpreter ioUTCMicrosecondsNow!
Item was changed:
----- Method: SpurMemoryManager>>printFreeChunk: (in category 'debug printing') -----
printFreeChunk: freeChunk
+ <api>
- <doNotGenerate>
| numBytes |
numBytes := self bytesInObject: freeChunk.
coInterpreter
print: 'freeChunk '; printHexPtrnp: freeChunk;
print: ' bytes '; printNum: numBytes;
print: ' next '; printHexPtrnp: (self fetchPointer: self freeChunkNextIndex
ofFreeChunk: freeChunk).
numBytes / self allocationUnit > self numFreeLists ifTrue:
[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>>sortFreeListAt: (in category 'free space') -----
sortFreeListAt: i
"Sort the individual free list i so that the lowest address is at the head of the list.
Use an insertion sort with a scan for initially sorted elements."
| list next head |
list := freeLists at: i. "list of objects to be inserted"
list = 0 ifTrue: "empty list; we're done"
[^self].
head := list.
"scan list to find find first out-of-order element"
[(next := self fetchPointer: self freeChunkNextIndex ofObject: list) > list]
whileTrue:
[list := next].
"no out-of-order elements; list was already sorted; we're done"
next = 0 ifTrue:
[^self].
"detatch already sorted list"
+ self storePointer: self freeChunkNextIndex ofFreeChunk: list withValue: 0.
- self storePointer: self freeChunkNextIndex ofObject: list withValue: 0.
list := next.
[list ~= 0] whileTrue:
[| node prev |
"grab next node to be inserted"
next := self fetchPointer: self freeChunkNextIndex ofObject: list.
"search sorted list for insertion point"
prev := 0. "prev node for insertion sort"
node := head. "current node for insertion sort"
[node ~= 0
and: [node < list]] whileTrue:
[prev := node.
node := self fetchPointer: self freeChunkNextIndex ofObject: node].
"insert the node into the sorted list"
self assert: (node = 0 or: [node > list]).
prev = 0
ifTrue:
[head := list]
ifFalse:
[self storePointer: self freeChunkNextIndex
ofFreeChunk: prev
withValue: list].
self storePointer: self freeChunkNextIndex
ofFreeChunk: list
withValue: node.
list := next].
"replace the list with the sorted list"
freeLists at: i put: head!
Item was changed:
----- Method: SpurMemoryManager>>unlinkSolitaryFreeTreeNode: (in category 'free space') -----
unlinkSolitaryFreeTreeNode: freeTreeNode
"Unlink a freeTreeNode. Assumes the node has no list (null next link)."
| parent smaller larger |
self assert: (self fetchPointer: self freeChunkNextIndex ofObject: freeTreeNode) = 0.
"case 1. interior node has one child, P = parent, N = node, S = subtree (mirrored for large vs small)
___ ___
| P | | P |
_/_ _/_
| N | => | S |
_/_
| S |
case 2: interior node has two children, , P = parent, N = node, L = smaller, left subtree, R = larger, right subtree.
add the left subtree to the bottom left of the right subtree (mirrored for large vs small)
___ ___
| P | | P |
_/_ _/_
| N | => | R |
_/_ _\_ _/_
| L | | R | | L |"
smaller := self fetchPointer: self freeChunkSmallerIndex ofFreeChunk: freeTreeNode.
larger := self fetchPointer: self freeChunkLargerIndex ofFreeChunk: freeTreeNode.
parent := self fetchPointer: self freeChunkParentIndex ofFreeChunk: freeTreeNode.
parent = 0
ifTrue: "no parent; stitch the subnodes back into the root"
[smaller = 0
ifTrue:
[self storePointer: self freeChunkParentIndex ofFreeChunk: larger withValue: 0.
freeLists at: 0 put: larger]
ifFalse:
[self storePointer: self freeChunkParentIndex ofFreeChunk: smaller withValue: 0.
freeLists at: 0 put: smaller.
larger ~= 0 ifTrue:
[self addFreeSubTree: larger]]]
ifFalse: "parent; stitch back into appropriate side of parent."
[smaller = 0
ifTrue: [self storePointer: (freeTreeNode = (self fetchPointer: self freeChunkSmallerIndex ofFreeChunk: parent)
ifTrue: [self freeChunkSmallerIndex]
ifFalse: [self freeChunkLargerIndex])
ofFreeChunk: parent
withValue: larger.
larger ~= 0 ifTrue:
[self storePointer: self freeChunkParentIndex
+ ofFreeChunk: larger
- ofObject: larger
withValue: parent]]
ifFalse:
[self storePointer: (freeTreeNode = (self fetchPointer: self freeChunkSmallerIndex ofFreeChunk: parent)
ifTrue: [self freeChunkSmallerIndex]
ifFalse: [self freeChunkLargerIndex])
ofFreeChunk: parent
withValue: smaller.
self storePointer: self freeChunkParentIndex
+ ofFreeChunk: smaller
- ofObject: smaller
withValue: parent.
larger ~= 0 ifTrue:
[self addFreeSubTree: larger]]]!
Item was changed:
----- Method: StackInterpreter>>markAndTraceStackPage: (in category 'object memory support') -----
markAndTraceStackPage: thePage
| theSP theFP frameRcvrOffset callerFP oop |
<var: #thePage type: #'StackPage *'>
<var: #theSP type: #'char *'>
<var: #theFP type: #'char *'>
<var: #frameRcvrOffset type: #'char *'>
<var: #callerFP type: #'char *'>
<inline: false>
self assert: (stackPages isFree: thePage) not.
theSP := thePage headSP.
theFP := thePage headFP.
"Skip the instruction pointer on top of stack of inactive pages."
thePage = stackPage ifFalse:
[theSP := theSP + BytesPerWord].
[frameRcvrOffset := self frameReceiverOffset: theFP.
[theSP <= frameRcvrOffset] whileTrue:
[oop := stackPages longAt: theSP.
+ (objectMemory isImmediate: oop) ifFalse:
- (objectMemory isIntegerObject: oop) ifFalse:
[objectMemory markAndTrace: oop].
theSP := theSP + BytesPerWord].
(self frameHasContext: theFP) ifTrue:
[self assert: (objectMemory isContext: (self frameContext: theFP)).
objectMemory markAndTrace: (self frameContext: theFP)].
objectMemory markAndTrace: (self iframeMethod: theFP).
(callerFP := self frameCallerFP: theFP) ~= 0] whileTrue:
[theSP := theFP + FoxCallerSavedIP + BytesPerWord.
theFP := callerFP].
theSP := theFP + FoxCallerSavedIP. "caller ip is frameCallerContext in a base frame"
[theSP <= thePage baseAddress] whileTrue:
[oop := stackPages longAt: theSP.
+ (objectMemory isImmediate: oop) ifFalse:
- (objectMemory isIntegerObject: oop) ifFalse:
[objectMemory markAndTrace: oop].
theSP := theSP + BytesPerWord]!
More information about the Vm-dev
mailing list