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]!
vm-dev@lists.squeakfoundation.org