Vm-dev October 2013

vm-dev@lists.squeakfoundation.org

30 participants
145 discussions

VM Maker: VMMaker.oscog-eem.469.mcz
by commits＠source.squeak.org 21 Oct '13

21 Oct '13

Eliot Miranda uploaded a new version of VMMaker to project VM Maker: http://source.squeak.org/VMMaker/VMMaker.oscog-eem.469.mcz ==================== Summary ==================== Name: VMMaker.oscog-eem.469 Author: eem Time: 20 October 2013, 5:15:49.893 pm UUID: 9a1b817f-2cee-487a-8c07-6444e28a16aa Ancestors: VMMaker.oscog-eem.468 Rethink the sorting of free space for exact-fit compact post global GC. Since the sweep to free unmarked objects is linear through old space it can also sort free space. So freeUnmarkedObjectsAndNilUnmarkedWeaklingSlots => freeUnmarkedObjectsNilUnmarkedWeaklingSlotsAndSortAndCoallesceFreeSpace (glup ;-) ). Make sure that bridges are marked so they won't be freed in fUONUWASACFS. Add freeChunkPrevIndex to link next nodes to their precedessors so that free chunks can be quickly removed during coallescing. Implement an iterative freeTreeNodesDo: so that Slang can inline the block arguments to it. Refactor the code that removes a tree node in allocateOldSpaceChunkOfBytes: et al, out into unlinkSolitaryFreeTreeNode: Still have to reverse small list heads post-sweep and account for free space properly. =============== Diff against VMMaker.oscog-eem.468 =============== Item was added: + ----- Method: Spur32BitMemoryManager>>coallesce:and: (in category 'gc - global') ----- + coallesce: 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 longAt: obj2 - self baseHeaderSize) + (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 bytesInObject: obj2). + + "if obj1 already has a double header things are simple..." + header1NumSlots = self numSlotsMask ifTrue: + [self longAt: obj1 - self baseHeaderSize put: obj2slots + (self longAt: obj1 - self baseHeaderSize). + ^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 bytesInObject: obj1). + newNumSlots := obj2slots + header1NumSlots. + + "if obj1 still only requires a single header things are simple..." + newNumSlots < self numSlotsMask ifTrue: + [self byteAt: obj1 + (self numSlotsFullShift / BitsPerByte) + 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 changed: ----- Method: Spur32BitMemoryManager>>initSegmentBridgeWithBytes:at: (in category 'segments') ----- initSegmentBridgeWithBytes: numBytes at: address <var: #numBytes type: #usqLong> | numSlots | "must have room for a double header" self assert: (numBytes \\ self allocationUnit = 0 and: [numBytes >= (self baseHeaderSize + self baseHeaderSize)]). self flag: #endianness. numSlots := numBytes - self baseHeaderSize - self baseHeaderSize >> self shiftForWord. self longAt: address put: numSlots; longAt: address + 4 put: self numSlotsMask << self numSlotsHalfShift; longAt: address + 8 put: (1 << self pinnedBitShift) + (self wordIndexableFormat << self formatShift) + self segmentBridgePun; + longAt: address + 12 put: self numSlotsMask << self numSlotsHalfShift + + (1 << self markedBitHalfShift)! - longAt: address + 12 put: self numSlotsMask << self numSlotsHalfShift! Item was removed: - ----- Method: Spur32BitMemoryManager>>reInitSegmentBridge: (in category 'segments') ----- - reInitSegmentBridge: bridgeOop - "On image write the segment manager replaces the header of the bridge - with the size of the following segment. This method restores that header." - <var: #numBytes type: #usqLong> - self longAt: bridgeOop put: (1 << self pinnedBitShift) - + (self wordIndexableFormat << self formatShift) - + self segmentBridgePun; - longAt: bridgeOop + 4 put: self numSlotsMask << self numSlotsHalfShift! Item was added: + ----- Method: Spur32BitMemoryManager>>sortedFreeObject: (in category 'free space') ----- + sortedFreeObject: objOop + "A variant of freeObject: that assumes objOop already has its valid number of slots, etc, + but makes sure the freeChunkPrevIndex is valid." + | bytes treeNode nextNode | + bytes := self bytesInObject: objOop. + totalFreeOldSpace := totalFreeOldSpace + bytes. + self longAt: objOop put: 0. + treeNode := self addToFreeList: objOop bytes: bytes. + treeNode ~= 0 ifTrue: + [self storePointer: self freeChunkPrevIndex ofFreeChunk: objOop withValue: treeNode]. + nextNode := self fetchPointer: self freeChunkNextIndex ofObject: objOop. + nextNode ~= 0 ifTrue: + [self storePointer: self freeChunkPrevIndex ofFreeChunk: nextNode withValue: objOop]! Item was changed: ----- Method: Spur64BitMemoryManager>>initSegmentBridgeWithBytes:at: (in category 'segments') ----- initSegmentBridgeWithBytes: numBytes at: address | numSlots | <var: #numBytes type: #usqLong> self assert: (numBytes >= (self baseHeaderSize + self baseHeaderSize) and: [numBytes \\ self allocationUnit = 0]). numSlots := numBytes - self baseHeaderSize - self baseHeaderSize >> self shiftForWord. self longAt: address put: self numSlotsMask << self numSlotsFullShift + numSlots; longAt: address + self baseHeaderSize put: (self numSlotsMask << self numSlotsFullShift) + (1 << self pinnedBitShift) + + (1 << self markedBitFullShift) + (self wordIndexableFormat << self formatShift) + self segmentBridgePun! Item was removed: - ----- Method: Spur64BitMemoryManager>>reInitSegmentBridge: (in category 'segments') ----- - reInitSegmentBridge: bridgeOop - "On image write the segment manager replaces the header of the bridge - with the size of the following segment. This method restores that header." - self longAt: bridgeOop - put: (self numSlotsMask << self numSlotsFullShift) - + (1 << self pinnedBitShift) - + (self wordIndexableFormat << self formatShift) - + self segmentBridgePun! Item was changed: CogClass subclass: #SpurMemoryManager (excessive size, no diff calculated) 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." | childBytes parent child index | "coInterpreter transcript ensureCr. coInterpreter print: 'freeing '. self printFreeChunk: freeChunk." self assert: (self isFreeObject: freeChunk). self assert: chunkBytes = (self bytesInObject: freeChunk). index := chunkBytes / self allocationUnit. index < self numFreeLists ifTrue: [self storePointer: self freeChunkNextIndex ofFreeChunk: freeChunk withValue: (freeLists at: index). freeLists at: index put: freeChunk. freeListsMask := freeListsMask bitOr: 1 << index. + ^0]. - ^self]. 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]. - ^self]. "walk down the tree" parent := child. child := self fetchPointer: (childBytes > chunkBytes ifTrue: [self freeChunkSmallerIndex] ifFalse: [self freeChunkLargerIndex]) ofObject: child]. parent = 0 ifTrue: [self assert: (freeLists at: 0) = 0. freeLists at: 0 put: freeChunk. freeListsMask := freeListsMask bitOr: 1. + ^0]. - ^self]. "insert in tree" self storePointer: self freeChunkParentIndex ofFreeChunk: freeChunk withValue: parent. + self storePointer: (childBytes > chunkBytes - self storePointer: (childBytes > chunkBytes ifTrue: [self freeChunkSmallerIndex] ifFalse: [self freeChunkLargerIndex]) ofFreeChunk: parent + withValue: freeChunk. + ^0! - withValue: freeChunk! Item was changed: ----- Method: SpurMemoryManager>>allFreeObjectsDo: (in category 'free space') ----- allFreeObjectsDo: aBlock | obj | 1 to: self numFreeLists - 1 do: [:i| obj := freeLists at: i. [obj ~= 0] whileTrue: [aBlock value: obj. obj := self fetchPointer: self freeChunkNextIndex ofFreeChunk: obj]]. + self allObjectsInFreeTreeDo: aBlock! - self allObjectsInFreeTree: (freeLists at: 0) do: aBlock! Item was added: + ----- Method: SpurMemoryManager>>allObjectsInFreeTreeDo: (in category 'free space') ----- + allObjectsInFreeTreeDo: aBlock + "Enumerate all objects in the free tree (in order, smaller to larger). + 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." + <inline: true> + self freeTreeNodesDo: + [:freeTreeNode| | next | + next := freeTreeNode. + [aBlock value: next. + next := self fetchPointer: self freeChunkNextIndex ofFreeChunk: next. + next ~= 0] whileTrue]! Item was added: + ----- Method: SpurMemoryManager>>allOldSpaceEntitiesForCoallescingDo: (in category 'object enumeration') ----- + allOldSpaceEntitiesForCoallescingDo: aBlock + <inline: true> + | prevObj prevPrevObj objOop rawNumSlots rawNumSlotsAfter | + prevPrevObj := prevObj := nil. + objOop := self firstObject. + [self assert: objOop \\ self allocationUnit = 0. + objOop < freeOldSpaceStart] whileTrue: + [rawNumSlots := self rawNumSlotsOf: objOop. + aBlock value: objOop. + "If the number of slot changes coallescing changed an object from a single to a double header." + rawNumSlotsAfter := self rawNumSlotsOf: objOop. + (rawNumSlotsAfter ~= rawNumSlots + and: [rawNumSlotsAfter = self numSlotsMask]) ifTrue: + [objOop := objOop + self baseHeaderSize. + self assert: (self objectAfter: prevObj limit: freeOldSpaceStart) = objOop]. + prevPrevObj := prevObj. + prevObj := objOop. + objOop := self objectAfter: objOop limit: freeOldSpaceStart]. + self touch: prevPrevObj. + self touch: prevObj! 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 | - | initialIndex chunk index nodeBytes parent child smaller larger | "for debugging:" "totalFreeOldSpace := self totalFreeListBytes" totalFreeOldSpace := totalFreeOldSpace - chunkBytes. "be optimistic (& don't wait for the write)" initialIndex := chunkBytes / self allocationUnit. (initialIndex < self numFreeLists and: [1 << initialIndex <= freeListsMask]) ifTrue: [(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) 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 := 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" - "no list; remove an interior node; reorder tree simply. two cases (which have mirrors, for four total): - case 1. interior node has one child, P = parent, N = node, S = subtree (mirrored for large vs small) - ___ ___ - | P | | P | - _/_ _/_ - | N | => | S | - _/_ - | S | - - case 2: interior node has two children, , P = parent, N = node, L = smaller, left subtree, R = larger, right subtree. - add the left subtree to the bottom left of the right subtree (mirrored for large vs small) - ___ ___ - | P | | P | - _/_ _/_ - | N | => | R | - _/_ _\_ _/_ - | L | | R | | L |" - chunk := parent. + self unlinkSolitaryFreeTreeNode: chunk. + - smaller := self fetchPointer: self freeChunkSmallerIndex ofFreeChunk: chunk. - larger := self fetchPointer: self freeChunkLargerIndex ofFreeChunk: chunk. - parent := self fetchPointer: self freeChunkParentIndex ofFreeChunk: chunk. - parent = 0 - ifTrue: "no parent; stitch the subnodes back into the root" - [smaller = 0 - ifTrue: - [self storePointer: self freeChunkParentIndex ofFreeChunk: larger withValue: 0. - freeLists at: 0 put: larger] - ifFalse: - [self storePointer: self freeChunkParentIndex ofFreeChunk: smaller withValue: 0. - freeLists at: 0 put: smaller. - larger ~= 0 ifTrue: - [self addFreeSubTree: larger]]] - ifFalse: "parent; stitch back into appropriate side of parent." - [smaller = 0 - ifTrue: - [self storePointer: (chunk = (self fetchPointer: self freeChunkSmallerIndex ofFreeChunk: parent) - ifTrue: [self freeChunkSmallerIndex] - ifFalse: [self freeChunkLargerIndex]) - ofFreeChunk: parent - withValue: larger. - larger ~= 0 ifTrue: - [self storePointer: self freeChunkParentIndex - ofFreeChunk: larger - withValue: parent]] - ifFalse: - [self storePointer: (chunk = (self fetchPointer: self freeChunkSmallerIndex ofFreeChunk: parent) - ifTrue: [self freeChunkSmallerIndex] - ifFalse: [self freeChunkLargerIndex]) - ofFreeChunk: parent - withValue: smaller. - self storePointer: self freeChunkParentIndex - ofFreeChunk: smaller - withValue: parent. - larger ~= 0 ifTrue: - [self addFreeSubTree: larger]]]. "if there's space left over, add the fragment back." chunkBytes ~= nodeBytes ifTrue: [self freeChunkWithBytes: nodeBytes - chunkBytes at: (self startOfObject: chunk) + chunkBytes]. ^self startOfObject: chunk! Item was changed: ----- Method: SpurMemoryManager>>allocateOldSpaceChunkOfExactlyBytes: (in category 'free space') ----- allocateOldSpaceChunkOfExactlyBytes: chunkBytes "Answer a chunk of oldSpace from the free lists, if one of this size is available, otherwise answer nil. N.B. the chunk is simply a pointer, it has no valid header. The caller *must* fill in the header correctly." + | initialIndex node nodeBytes child | - | initialIndex node nodeBytes parent child smaller larger | "for debugging:" "totalFreeOldSpace := self totalFreeListBytes" initialIndex := chunkBytes / self allocationUnit. initialIndex < self numFreeLists ifTrue: [(1 << initialIndex <= freeListsMask and: [(node := freeLists at: initialIndex) ~= 0]) ifTrue: [self assert: node = (self startOfObject: node). self assert: (self isValidFreeObject: node). 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. - "no list; remove an interior node; reorder tree simply. two cases (which have mirrors, for four total): - case 1. interior node has one child, P = parent, N = node, S = subtree (mirrored for large vs small) - ___ ___ - | P | | P | - _/_ _/_ - | N | => | S | - _/_ - | S | - - case 2: interior node has two children, , P = parent, N = node, L = smaller, left subtree, R = larger, right subtree. - add the left subtree to the bottom left of the right subtree (mirrored for large vs small) - ___ ___ - | P | | P | - _/_ _/_ - | N | => | R | - _/_ _\_ _/_ - | L | | R | | L |" - - smaller := self fetchPointer: self freeChunkSmallerIndex ofFreeChunk: node. - larger := self fetchPointer: self freeChunkLargerIndex ofFreeChunk: node. - parent := self fetchPointer: self freeChunkParentIndex ofFreeChunk: node. - parent = 0 - ifTrue: "no parent; stitch the subnodes back into the root" - [smaller = 0 - ifTrue: - [self storePointer: self freeChunkParentIndex ofFreeChunk: larger withValue: 0. - freeLists at: 0 put: larger] - ifFalse: - [self storePointer: self freeChunkParentIndex ofFreeChunk: smaller withValue: 0. - freeLists at: 0 put: smaller. - larger ~= 0 ifTrue: - [self addFreeSubTree: larger]]] - ifFalse: "parent; stitch back into appropriate side of parent." - [smaller = 0 - ifTrue: [self storePointer: (node = (self fetchPointer: self freeChunkSmallerIndex ofFreeChunk: parent) - ifTrue: [self freeChunkSmallerIndex] - ifFalse: [self freeChunkLargerIndex]) - ofFreeChunk: parent - withValue: larger. - self storePointer: self freeChunkParentIndex - ofObject: larger - withValue: parent] - ifFalse: - [self storePointer: (node = (self fetchPointer: self freeChunkSmallerIndex ofFreeChunk: parent) - ifTrue: [self freeChunkSmallerIndex] - ifFalse: [self freeChunkLargerIndex]) - ofFreeChunk: parent - withValue: smaller. - self storePointer: self freeChunkParentIndex - ofObject: smaller - withValue: parent. - larger ~= 0 ifTrue: - [self addFreeSubTree: larger]]]. totalFreeOldSpace := totalFreeOldSpace - chunkBytes. ^self startOfObject: node! Item was added: + ----- Method: SpurMemoryManager>>buildPrevLinksForLargeFreeChunks (in category 'free space') ----- + buildPrevLinksForLargeFreeChunks + | prevTreeNode | + prevTreeNode := 0. + self freeTreeNodesDo: + [:freeTreeNode| | next prev | + "freeTreeNodesDo: is supposed to be an in-order traversal from smaller to larger..." + self assert: (prevTreeNode = 0 or: [(self numSlotsOfAny: prevTreeNode) < (self numSlotsOfAny: freeTreeNode)]). + self storePointer: self freeChunkPrevIndex ofFreeChunk: freeTreeNode withValue: 0. + prev := freeTreeNode. + [(next := self fetchPointer: self freeChunkNextIndex ofObject: prev) ~= 0] whileTrue: + [self storePointer: self freeChunkPrevIndex ofFreeChunk: next withValue: prev. + prev := next]]! Item was added: + ----- Method: SpurMemoryManager>>coallesce:and: (in category 'gc - global') ----- + coallesce: obj1 and: obj2 + self subclassResponsibility! Item was added: + ----- Method: SpurMemoryManager>>detatchLargeFreeObject: (in category 'free space') ----- + detatchLargeFreeObject: freeChunk + | prev next | + prev := self fetchPointer: self freeChunkPrevIndex ofObject: freeChunk. + next := self fetchPointer: self freeChunkNextIndex ofObject: freeChunk. + prev = 0 + ifTrue: "freeChunk is a treeNode" + [next = 0 + ifTrue: "remove it from the tree" + [self unlinkSolitaryFreeTreeNode: freeChunk] + ifFalse: "replace freeChunk by its next node." + [self unlinkFreeTreeNode: freeChunk withSiblings: next]] + ifFalse: "freeChunk is a list node; simple" + [self storePointer: self freeChunkNextIndex ofFreeChunk: prev withValue: next. + next ~= 0 ifTrue: + [self storePointer: self freeChunkPrevIndex ofFreeChunk: next withValue: prev]]! Item was added: + ----- Method: SpurMemoryManager>>freeChunkPrevIndex (in category 'free space') ----- + freeChunkPrevIndex + "for quickly unlinking nodes in the tree of large free chunks." + ^5! Item was added: + ----- Method: SpurMemoryManager>>freeTreeNodesDo: (in category 'free space') ----- + freeTreeNodesDo: aBlock + "Enumerate all nodes in the free tree (in order, smaller to larger), + bit *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." + <inline: true> + | treeNode cameFrom | + treeNode := freeLists at: 0. + treeNode = 0 ifTrue: + [^self]. + cameFrom := -1. + [| smallChild largeChild | + smallChild := self fetchPointer: self freeChunkSmallerIndex ofFreeChunk: treeNode. + largeChild := self fetchPointer: self freeChunkLargerIndex ofFreeChunk: treeNode. + "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: + [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 removed: - ----- Method: SpurMemoryManager>>freeUnmarkedObjectsAndNilUnmarkedWeaklingSlots (in category 'gc - global') ----- - freeUnmarkedObjectsAndNilUnmarkedWeaklingSlots - self checkFreeSpace. - scavenger forgetUnmarkedRememberedObjects. - self allOldSpaceObjectsDo: - [:o| - (self isMarked: o) - ifTrue: - [self setIsMarkedOf: o to: false. - ((self isWeakNonImm: o) - and: [self nilUnmarkedWeaklingSlots: o]) ifTrue: - [coInterpreter signalFinalization: o]] - ifFalse: - [self assert: (self isRemembered: o) not. "scavenger should have clearer this above" - self freeObject: o]]. - self checkFreeSpace! Item was added: + ----- Method: SpurMemoryManager>>freeUnmarkedObjectsNilUnmarkedWeaklingSlotsAndSortAndCoallesceFreeSpace (in category 'gc - global') ----- + freeUnmarkedObjectsNilUnmarkedWeaklingSlotsAndSortAndCoallesceFreeSpace + self checkFreeSpace. + scavenger forgetUnmarkedRememberedObjects. + "for coallescing, specifically detatchLargeFreeObject: below, link large chunks to their tree nodes." + self buildPrevLinksForLargeFreeChunks. + self checkFreeSpace. + "for sorting free space throw away the small list heads, rebuilding them below.". + self resetSmallFreeListHeads. + self allOldSpaceEntitiesForCoallescingDo: + [:o| + (self isMarked: o) + ifTrue: + [self setIsMarkedOf: o to: false. + ((self isWeakNonImm: o) + and: [self nilUnmarkedWeaklingSlots: o]) ifTrue: + [coInterpreter signalFinalization: o]] + ifFalse: "unmarked; two cases, an unreachable object or a free chunk." + [| here next | + self assert: (self isRemembered: o) not. "scavenger should have cleared this above" + here := o. + next := self objectAfter: here limit: endOfMemory. + (self isMarked: next) + ifTrue: "common case" + [(self isLargeFreeObject: o) ifFalse: + [self sortedFreeObject: o]] + ifFalse: "coallescing; rare case" + [self assert: (self isRemembered: o) not. + (self isLargeFreeObject: o) ifTrue: + [self detatchLargeFreeObject: o]. + [statCoallesces := statCoallesces + 1. + here := self coallesce: here and: next. + next := self objectAfter: here limit: endOfMemory. + next = endOfMemory or: [self isMarked: next]] whileFalse. + self sortedFreeObject: here]]]. + self checkFreeSpace! Item was changed: ----- Method: SpurMemoryManager>>globalGarbageCollect (in category 'gc - global') ----- globalGarbageCollect self markObjects. + self freeUnmarkedObjectsNilUnmarkedWeaklingSlotsAndSortAndCoallesceFreeSpace. - self freeUnmarkedObjectsAndNilUnmarkedWeaklingSlots. self exactFitCompact! Item was changed: ----- Method: SpurMemoryManager>>initialize (in category 'initialization') ----- initialize "We can put all initializations that set something to 0 or to false here. In C all global variables are initialized to 0, and 0 is false." remapBuffer := Array new: RemapBufferSize. remapBufferCount := extraRootCount := 0. "see below" freeListsMask := totalFreeOldSpace := lowSpaceThreshold := 0. checkForLeaks := 0. needGCFlag := signalLowSpace := scavengeInProgress := marking := false. becomeEffectsFlags := 0. statScavenges := statIncrGCs := statFullGCs := 0. statScavengeGCUsecs := statIncrGCUsecs := statFullGCUsecs := statGCEndUsecs := 0. statSGCDeltaUsecs := statIGCDeltaUsecs := statFGCDeltaUsecs := 0. statGrowMemory := statShrinkMemory := statRootTableCount := statTenures := statSurvivorCount := 0. statRootTableOverflows := statSweepCount := statMarkCount := statSpecialMarkCount := statMkFwdCount := 0. + statCoallesces := 0. "We can initialize things that are allocated but are lazily initialized." unscannedEphemerons := SpurContiguousObjStack new. "we can initialize things that are virtual in C." scavenger := SpurGenerationScavengerSimulator new manager: self; yourself. segmentManager := SpurSegmentManager new manager: self; yourself. "We can also initialize here anything that is only for simulation." heapMap := self wordSize = 4 ifTrue: [CogCheck32BitHeapMap new]. "N.B. We *don't* initialize extraRoots because we don't simulate it."! Item was added: + ----- Method: SpurMemoryManager>>isLargeFreeObject: (in category 'free space') ----- + isLargeFreeObject: objOop + ^(self isFreeObject: objOop) + and: [(self bytesInObject: objOop) / self allocationUnit >= self numFreeLists]! Item was changed: ----- Method: SpurMemoryManager>>markAccessibleObjects (in category 'gc - global') ----- markAccessibleObjects self assert: self validClassTableRootPages. + self assert: segmentManager allBridgesMarked. marking := true. self cCode: [] "for debugging markAndTrace: set (MarkStackRecord := OrderedCollection new)" inSmalltalk: [MarkStackRecord ifNotNil: [MarkStackRecord resetTo: 1]]. self markAndTraceObjStack: self markStack andContents: false. self assert: self validClassTableRootPages. self markAndTraceObjStack: self ephemeronQueue andContents: true. self assert: self validClassTableRootPages. self markAndTrace: self freeListsObj. self markAndTrace: hiddenRootsObj. self markAndTrace: self specialObjectsOop. coInterpreter markAndTraceInterpreterOops: true. self markAndFireEphemerons. marking := false! Item was removed: - ----- Method: SpurMemoryManager>>reInitSegmentBridge: (in category 'segments') ----- - reInitSegmentBridge: bridgeOop - "On image write the segment manager replaces the header of the bridge - with the size of the following segment. This method restores that header." - ^self subclassResponsibility! Item was added: + ----- Method: SpurMemoryManager>>resetSmallFreeListHeads (in category 'free space') ----- + resetSmallFreeListHeads + 1 to: self numFreeLists - 1 do: + [:i| freeLists at: i put: 0]! Item was changed: ----- Method: SpurMemoryManager>>sortFreeSpace (in category 'free space') ----- sortFreeSpace "Sort free space for best-fit compaction. Sort the individual free lists so that the lowest address is at the head of each list. Sort the large chunks through the freeChunkNextAddressIndex from low to high, with the head in sortedFreeChunks." self checkFreeSpace. 1 to: self numFreeLists - 1 do: [:i| self sortFreeListAt: i]. sortedFreeChunks := 0. + self allObjectsInFreeTreeDo: - self allObjectsInFreeTree: (freeLists at: 0) do: [:f| | node prev | node := sortedFreeChunks. prev := 0. [node ~= 0 and: [node < f]] whileTrue: [prev := node. node := self fetchPointer: self freeChunkNextAddressIndex ofObject: node]. "insert the node into the sorted list" self assert: (node = 0 or: [node > f]). prev = 0 ifTrue: [sortedFreeChunks := f] ifFalse: [self storePointer: self freeChunkNextAddressIndex ofFreeChunk: prev withValue: f]. self storePointer: self freeChunkNextAddressIndex ofFreeChunk: f withValue: node]. self assert: self sortedFreeChunksAreSorted. self checkFreeSpace! Item was added: + ----- Method: SpurMemoryManager>>sortedFreeObject: (in category 'free space') ----- + sortedFreeObject: objOop + self subclassResponsibility! Item was added: + ----- Method: SpurMemoryManager>>unlinkFreeTreeNode:withSiblings: (in category 'free space') ----- + unlinkFreeTreeNode: freeTreeNode withSiblings: next + "Unlink a freeTreeNode. Assumes the node has a list (non-null next link)." + | parent smaller larger | + parent := self fetchPointer: self freeChunkParentIndex ofObject: freeTreeNode. + smaller := self fetchPointer: self freeChunkSmallerIndex ofObject: freeTreeNode. + larger := self fetchPointer: self freeChunkLargerIndex ofObject: freeTreeNode. + self storePointer: self freeChunkPrevIndex ofFreeChunk: next withValue: 0. + parent = 0 + ifTrue: [freeLists at: 0 put: next] + ifFalse: + [self storePointer: (freeTreeNode = (self fetchPointer: self freeChunkSmallerIndex + ofObject: parent) + ifTrue: [self freeChunkSmallerIndex] + ifFalse: [self freeChunkLargerIndex]) + ofFreeChunk: parent + withValue: next]. + self storePointer: self freeChunkSmallerIndex ofFreeChunk: next withValue: smaller. + smaller ~= 0 ifTrue: + [self storePointer: self freeChunkParentIndex ofFreeChunk: smaller withValue: next]. + self storePointer: self freeChunkLargerIndex ofFreeChunk: next withValue: larger. + larger ~= 0 ifTrue: + [self storePointer: self freeChunkParentIndex ofFreeChunk: larger withValue: next]! Item was added: + ----- Method: SpurMemoryManager>>unlinkSolitaryFreeTreeNode: (in category 'free space') ----- + unlinkSolitaryFreeTreeNode: freeTreeNode + "Unlink a freeTreeNode. Assumes the node has no list (null next link)." + | parent smaller larger | + + "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. + self storePointer: self freeChunkParentIndex + 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 + ofObject: smaller + withValue: parent. + larger ~= 0 ifTrue: + [self addFreeSubTree: larger]]]! Item was added: + ----- Method: SpurSegmentManager>>allBridgesMarked (in category 'debug support') ----- + allBridgesMarked + 0 to: numSegments - 1 do: + [:i| | bridgeObj | + bridgeObj := (segments at: i) segStart + + (segments at: i) segSize + - manager baseHeaderSize. + self assert: (manager isSegmentBridge: bridgeObj). + (manager isMarked: bridgeObj) ifFalse: + [^false]]. + ^true + + "for debugging:" + "(0 to: numSegments - 1) select: + [:i| | bridgeObj | + bridgeObj := (segments at: i) segStart + + (segments at: i) segSize + - manager baseHeaderSize. + self assert: (manager isSegmentBridge: bridgeObj). + manager isMarked: bridgeObj]"! Item was changed: ----- Method: SpurSegmentManager>>collapseSegmentsPostSwizzle (in category 'snapshot') ----- collapseSegmentsPostSwizzle "The image has been loaded, old segments reconstructed, and the loaded image swizzled into a single contiguous segment. Collapse the segments intio one." | bridge | canSwizzle := false. firstSegmentSize ifNil: "true when used by SpurBootstrap to transform an image" [^self]. numSegments := 1. + (segments at: 0) - (self addressOf: (segments at: 0)) segStart: manager newSpaceLimit; segSize: manager endOfMemory - manager newSpaceLimit. "finally plant a bridge at the end of the coallesced segment and cut back the manager's notion of the end of memory to immediately before the bridge." bridge := manager endOfMemory - manager bridgeSize. + self assert: bridge = ((segments at: 0) segStart + + (segments at: 0) segSize + - (manager bridgeSize)). manager initSegmentBridgeWithBytes: manager bridgeSize at: bridge; setEndOfMemory: bridge!

1 0

[commit][2793] add ioExitWithErrorCode()
by commits＠squeakvm.org 20 Oct '13

20 Oct '13

Revision: 2793 Author: piumarta Date: 2013-10-20 08:16:00 -0700 (Sun, 20 Oct 2013) Log Message: ----------- add ioExitWithErrorCode() Modified Paths: -------------- trunk/platforms/Mac OS/vm/sqMacMain.c trunk/platforms/unix/ChangeLog trunk/platforms/unix/vm/sqUnixMain.c trunk/platforms/win32/vm/sqWin32Window.c Modified: trunk/platforms/Mac OS/vm/sqMacMain.c =================================================================== --- trunk/platforms/Mac OS/vm/sqMacMain.c 2013-10-20 15:06:47 UTC (rev 2792) +++ trunk/platforms/Mac OS/vm/sqMacMain.c 2013-10-20 15:16:00 UTC (rev 2793) @@ -87,6 +87,8 @@ 3.8.21b1 Jan 14th, 2009 JMM fix issue with mmap allocation, only allow explicitly to avoid mmap problems on nfs 4.0.1b1 Apr 9th, 2009 JMM add logic for etoys on a stick 4.2.1b1 Aug 19th, 2009 JMM add gSqueakResourceDirectoryName + + ------- Oct 19th, 2013 dtl add ioExitWithErrorCode(int ec) */ @@ -326,7 +328,13 @@ return 0; } -int ioExit(void) { +sqInt ioExit(void) +{ + return ioExitWithErrorCode(0); +} + +sqInt ioExitWithErrorCode(int ec) +{ UnloadScrap(); ioShutdownAllModules(); if (!gSqueakHeadless || gSqueakBrowserWasHeadlessButMadeFullScreen) @@ -741,4 +749,4 @@ int clearProfile(void){return 0;} int dumpProfile(void){return 0;} int startProfiling(void){return 0;} -int stopProfiling(void) {return 0;} \ No newline at end of file +int stopProfiling(void) {return 0;} Modified: trunk/platforms/unix/ChangeLog =================================================================== --- trunk/platforms/unix/ChangeLog 2013-10-20 15:06:47 UTC (rev 2792) +++ trunk/platforms/unix/ChangeLog 2013-10-20 15:16:00 UTC (rev 2793) @@ -1,5 +1,7 @@ 2013-10-20 Ian Piumarta <com -dot- gmail -at- piumarta (backwards)> + * vm/sqUnixMain.c (ioExitWithErrorCode): Added. + * plugins/SqueakSSL/sqUnixOpenSSL.c: Fix memory leaks (thanks to Levente Uzonyl). Modified: trunk/platforms/unix/vm/sqUnixMain.c =================================================================== --- trunk/platforms/unix/vm/sqUnixMain.c 2013-10-20 15:06:47 UTC (rev 2792) +++ trunk/platforms/unix/vm/sqUnixMain.c 2013-10-20 15:16:00 UTC (rev 2793) @@ -1464,8 +1464,14 @@ sqInt ioExit(void) { + return ioExitWithErrorCode(0); +} + +sqInt ioExitWithErrorCode(int ec) +{ dpy->winExit(); - exit(0); + exit(ec); + return ec; } #if defined(DARWIN) Modified: trunk/platforms/win32/vm/sqWin32Window.c =================================================================== --- trunk/platforms/win32/vm/sqWin32Window.c 2013-10-20 15:06:47 UTC (rev 2792) +++ trunk/platforms/win32/vm/sqWin32Window.c 2013-10-20 15:16:00 UTC (rev 2793) @@ -1400,10 +1400,15 @@ int ioExit(void) { + return ioExitWithErrorCode(0); +} + +sqInt ioExitWithErrorCode(int ec) +{ inCleanExit = 1; - exit(0); + exit(ec); /* avoid the warnings here */ - return 0; + return ec; } int ioBeep(void)

4 3

[commit][2792] fix memory leaks in SqueakSSL
by commits＠squeakvm.org 20 Oct '13

20 Oct '13

Revision: 2792 Author: piumarta Date: 2013-10-20 08:06:47 -0700 (Sun, 20 Oct 2013) Log Message: ----------- fix memory leaks in SqueakSSL Modified Paths: -------------- trunk/platforms/unix/ChangeLog trunk/platforms/unix/plugins/SqueakSSL/sqUnixOpenSSL.c Modified: trunk/platforms/unix/ChangeLog =================================================================== --- trunk/platforms/unix/ChangeLog 2013-10-19 19:35:14 UTC (rev 2791) +++ trunk/platforms/unix/ChangeLog 2013-10-20 15:06:47 UTC (rev 2792) @@ -1,3 +1,8 @@ +2013-10-20 Ian Piumarta <com -dot- gmail -at- piumarta (backwards)> + + * plugins/SqueakSSL/sqUnixOpenSSL.c: Fix memory leaks (thanks to + Levente Uzonyl). + 2013-09-09 Ian Piumarta <com -dot- gmail -at- piumarta (backwards)> * cmake/configure (svnversion): Look for evidence of checked out Modified: trunk/platforms/unix/plugins/SqueakSSL/sqUnixOpenSSL.c =================================================================== --- trunk/platforms/unix/plugins/SqueakSSL/sqUnixOpenSSL.c 2013-10-19 19:35:14 UTC (rev 2791) +++ trunk/platforms/unix/plugins/SqueakSSL/sqUnixOpenSSL.c 2013-10-20 15:06:47 UTC (rev 2792) @@ -124,8 +124,15 @@ if(ssl == NULL) return 0; if(ssl->ctx) SSL_CTX_free(ssl->ctx); - if(ssl->ssl) SSL_free(ssl->ssl); + if(ssl->ssl) { + SSL_free(ssl->ssl); // This will also free bioRead and bioWrite + } else { + // SSL_new didn't get called, have to free bioRead and bioWrite manually + BIO_free_all(ssl->bioRead); + BIO_free_all(ssl->bioWrite); + } + if(ssl->certName) free(ssl->certName); if(ssl->peerName) free(ssl->peerName); @@ -394,6 +401,7 @@ switch(propID) { case SQSSL_PROP_CERTNAME: ssl->certName = property; break; default: + if(property) free(property); if(ssl->loglevel) printf("sqSetStringPropertySSL: Unknown property ID %d\n", propID); return 0; }

1 0

Primitive 60 vs methods with more than one argument
by Levente Uzonyi 20 Oct '13

20 Oct '13

Hi, the code of primitive 60 seems to be assuming that the method has exactly one argument, ignoring the actual number of arguments. This seems to be an unnecessary restriction, which makes it cumbersome/impossible to use it in methods which have more arguments, like #at:ifAbsent:. Since the primitive uses two objects from the top of the stack, it's possible to write a hackish method to see the potential benefits: ifAbsent: aBlock receiver: receiver at: index <primitive: 60> ^aBlock value The primitive will treat the variable receiver as the receiver, and index as the index. The real receiver is not used at all. This method performs 37% better than #at:ifAbsent for the case where the index is valid. Does it have any benefits not taking the actual number of arguments into account in this primitive? Cheers, Levente

2 4

VM Maker: VMMaker-dtl.327.mcz
by commits＠source.squeak.org 19 Oct '13

19 Oct '13

David T. Lewis uploaded a new version of VMMaker to project VM Maker: http://source.squeak.org/VMMaker/VMMaker-dtl.327.mcz ==================== Summary ==================== Name: VMMaker-dtl.327 Author: dtl Time: 19 October 2013, 3:00:23.112 pm UUID: ba3104e6-7926-482f-9ef1-cdf59721acb8 Ancestors: VMMaker-tpr.326 VMMaker 4.12.7 Adopt primitiveQuit from oscog with exit status parameter Reference http://bugs.squeak.org/view.php?id=7792 The 4.11.7 generated sources will include VMMaker-tpr.326 and VMMaker-tpr.325 =============== Diff against VMMaker-tpr.326 =============== Item was changed: ----- Method: InterpreterPrimitives>>primitiveQuit (in category 'system control primitives') ----- primitiveQuit + self ioExitWithErrorCode: (argumentCount = 1 ifTrue: [objectMemory integerValueOf: self stackTop] ifFalse: [0])! - self ioExit. - ! Item was changed: ----- Method: VMMaker class>>versionString (in category 'version testing') ----- versionString "VMMaker versionString" + ^'4.12.7'! - ^'4.12.6'!

1 0

primitiveQuit for the Interpreter VM
by Frank Shearar 19 Oct '13

19 Oct '13

Levente pointed out that while Cog has this primitive, the Interpreter VM doesn't, and so his Inbox submission (http://source.squeak.org/inbox/System-ul.528.mcz) can't really go into Trunk yet. Given that this is something that I feel strongly about - I need this primitive so that builds will actually _fail_ and not continue trying random things on things in random states - it seems likely that I'll be the one to implement the thing. SO. How might I go about porting the Cog version? Do I simply start to Read the Source? frank

4 4

Mac VM Maintainer resignation (for the general purpose VM, not for PharoVM)
by Esteban Lorenzano 19 Oct '13

19 Oct '13

Hi, This is an announce for VM-dev and Squeak-dev list, Pharo-dev list is copy to keep people informed. Last years I tried to keep a working version of the Mac builds of VM while at the same time trying to keep my job going. It was a hard work but I did my best. When I assumed the responsibility I said that my first task was going to be to automatize the builds and at the same time Igor was doing the same so I joined that effort. Since then the VM is buildable even by the not so good at VM level and I never seen the point in keeping the manual build or the non-smalltalk-generated configuration files. Nevertheless, I preferred to work on the new builds of Eliot than in the old interpreter and when keeping all working became more work that what I could manage, I choose to keep Stack and Cog VM working. Maybe because of that, or because the animosity between communities, or because what I'm doing just does not match Squeak vision, or because since Eliot is providing regular builds mine are not needed, truth is that I've seen my work mostly ignored in squeak community and for some of the people in vm-dev list. That's why I resign as a maintainer. I have a process that does not match squeak vision and is fair for squeak community to look for someone who does. I have no bad feelings, I'm complete grateful to the community for give me the opportunity (specially to John, who thrusted me) and to all the rest. I also know that there is great people both in vm-dev and in squeak-dev, but I cannot your mac-guy anymore (and I think this is obvious since ever). And of course I will continue working in the pharo flavor of VM :) Cheers, Esteban

3 3

VM Maker: VMMaker.oscog-eem.468.mcz
by commits＠source.squeak.org 19 Oct '13

19 Oct '13

Eliot Miranda uploaded a new version of VMMaker to project VM Maker: http://source.squeak.org/VMMaker/VMMaker.oscog-eem.468.mcz ==================== Summary ==================== Name: VMMaker.oscog-eem.468 Author: eem Time: 18 October 2013, 6:02:37.436 pm UUID: c604e6e0-398e-423c-b37d-478eca3fedf3 Ancestors: VMMaker.oscog-eem.467 Remove an unused recursive method (stackValue:ofObjStack:put:). In Slang, prevent inlining of recursive methods. =============== Diff against VMMaker.oscog-eem.467 =============== Item was removed: - ----- Method: SpurMemoryManager>>stackValue:ofObjStack:put: (in category 'obj stacks') ----- - stackValue: offset ofObjStack: objStackPage put: aValue - | topx nextPage | - self assert: offset >= 0. - topx := self fetchPointer: ObjStackTopx ofObject: objStackPage. - offset < topx ifTrue: - [^self storePointer: ObjStackTopx + offset ofObjStack: objStackPage withValue: aValue]. - nextPage := self fetchPointer: ObjStackNextx ofObject: objStackPage. - nextPage = 0 ifTrue: - [self error: 'no such element on obj stack']. - ^self stackValue: offset - topx ofObjStack: nextPage put: aValue! Item was changed: ----- Method: TMethod>>inlineableFunctionCall:in: (in category 'inlining') ----- inlineableFunctionCall: aNode in: aCodeGen "Answer true if the given send node is a call to a 'functional' method--a method whose body is a single return statement of some expression and whose actual parameters can all be directly substituted." | m | self maybeBreakFor: aNode in: aCodeGen. ^aNode isSend and: [(m := aCodeGen methodNamed: aNode selector) notNil "nil if builtin or external function" + and: [m ~~ self and: [m isFunctional and: [(aCodeGen mayInline: m selector) + and: [aNode args allSatisfy: [ :a | self isSubstitutableNode: a intoMethod: m in: aCodeGen]]]]]]! - and: [aNode args allSatisfy: [ :a | self isSubstitutableNode: a intoMethod: m in: aCodeGen]]]]]! Item was changed: ----- Method: TMethod>>inlineableSend:in: (in category 'inlining') ----- inlineableSend: aNode in: aCodeGen "Answer true if the given send node is a call to a method that can be inlined." | m | self maybeBreakFor: aNode in: aCodeGen. aNode isSend ifFalse: [ ^false ]. m := aCodeGen methodNamed: aNode selector. "nil if builtin or external function" + ^m ~= nil and: [m ~~ self and: [m isComplete and: [aCodeGen mayInline: m selector]]]! - ^(m ~= nil) and: [m isComplete and: [aCodeGen mayInline: m selector]]!

1 0

VM Maker: VMMaker.oscog-eem.467.mcz
by commits＠source.squeak.org 19 Oct '13

19 Oct '13

Eliot Miranda uploaded a new version of VMMaker to project VM Maker: http://source.squeak.org/VMMaker/VMMaker.oscog-eem.467.mcz ==================== Summary ==================== Name: VMMaker.oscog-eem.467 Author: eem Time: 18 October 2013, 4:44:27.269 pm UUID: e8811a02-2211-46ed-9535-f48c5397ecc0 Ancestors: VMMaker.oscog-eem.466 Rewrite obj stacks to eliminate the awful double indirection so that both the mark stack and ephemeron queue can be stored in inst vars of SpurMemMgr. Simplify markAndTrace: so that it has less duplication and actually handles large objects correctly. Remember to mark the freeLists object. Implement freeing unmarked objs and nilling weak fields post scan-mark. Implement ephemeron processing. Add bounds checking to SpurMemMgrSimulator's fetchPointer: methods. Replace metaclassSizeBits with metaclassNumSlots and correct class name printing methods to avoid a bounds violation when applied to e.g. nilObj. Some isIntegerObject: => isImmediate:'s in CoInterpreter trace methods. =============== Diff against VMMaker.oscog-eem.466 =============== Item was changed: ----- Method: CoInterpreter>>markAndTracePrimTraceLog (in category 'debug support') ----- markAndTracePrimTraceLog "The prim trace log is a circular buffer of selectors. If there is an entry at primTraceLogIndex - 1 \\ PrimTraceBufferSize it has entries. If there is something at primTraceLogIndex it has wrapped." <inline: false> | limit | limit := self safe: primTraceLogIndex - 1 mod: PrimTraceLogSize. (primTraceLog at: limit) = 0 ifTrue: [^nil]. (primTraceLog at: primTraceLogIndex) ~= 0 ifTrue: [limit := PrimTraceLogSize - 1]. 0 to: limit do: [:i| | selector | selector := primTraceLog at: i. + (objectMemory isImmediate: selector) ifFalse: - (objectMemory isIntegerObject: selector) ifFalse: [objectMemory markAndTrace: selector]]! Item was changed: ----- Method: CoInterpreter>>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)]. (self isMachineCodeFrame: theFP) ifTrue: [self markAndTraceMachineCodeMethod: (self mframeCogMethod: theFP)] ifFalse: [objectMemory markAndTrace: (self iframeMethod: theFP)]. (callerFP := self frameCallerFP: theFP) ~= 0] whileTrue: [theSP := theFP + FoxCallerSavedIP + BytesPerWord. theFP := callerFP]. theSP := theFP + FoxCallerSavedIP + BytesPerWord. "caller ip is ceBaseReturnPC" [theSP <= thePage baseAddress] whileTrue: [oop := stackPages longAt: theSP. + (objectMemory isImmediate: oop) ifFalse: - (objectMemory isIntegerObject: oop) ifFalse: [objectMemory markAndTrace: oop]. theSP := theSP + BytesPerWord]! Item was changed: ----- Method: CoInterpreter>>markAndTraceTraceLog (in category 'object memory support') ----- markAndTraceTraceLog "The trace log is a circular buffer of pairs of entries. If there is an entry at traceLogIndex - 3 \\ TraceBufferSize it has entries. If there is something at traceLogIndex it has wrapped." <inline: false> | limit | limit := self safe: traceLogIndex - 3 mod: TraceBufferSize. (traceLog at: limit) = 0 ifTrue: [^nil]. (traceLog at: traceLogIndex) ~= 0 ifTrue: [limit := TraceBufferSize - 3]. 0 to: limit by: 3 do: [:i| | oop | oop := traceLog at: i. + (objectMemory isImmediate: oop) ifFalse: - (objectMemory isIntegerObject: oop) ifFalse: [objectMemory markAndTrace: oop]. oop := traceLog at: i + 1. + (objectMemory isImmediate: oop) ifFalse: - (objectMemory isIntegerObject: oop) ifFalse: [objectMemory markAndTrace: oop]]! Item was changed: ----- Method: CoInterpreter>>readImageFromFile:HeapSize:StartingAt: (in category 'image save/restore') ----- readImageFromFile: f HeapSize: desiredHeapSize StartingAt: imageOffset "Read an image from the given file stream, allocating the given amount of memory to its object heap. Fail if the image has an unknown format or requires more than the given amount of memory." "Details: This method detects when the image was stored on a machine with the opposite byte ordering from this machine and swaps the bytes automatically. Furthermore, it allows the header information to start 512 bytes into the file, since some file transfer programs for the Macintosh apparently prepend a Mac-specific header of this size. Note that this same 512 bytes of prefix area could also be used to store an exec command on Unix systems, allowing one to launch Smalltalk by invoking the image name as a command." "This code is based on C code by Ian Piumarta and Smalltalk code by Tim Rowledge. Many thanks to both of you!!!!" | swapBytes headerStart headerSize dataSize oldBaseAddr minimumMemory heapSize bytesRead bytesToShift hdrNumStackPages hdrEdenBytes hdrCogCodeSize headerFlags hdrMaxExtSemTabSize firstSegSize | <var: #f type: 'sqImageFile '> <var: #memStart type: 'usqInt'> <var: #desiredHeapSize type: 'usqInt'> <var: #headerStart type: 'squeakFileOffsetType '> <var: #dataSize type: 'size_t '> <var: #imageOffset type: 'squeakFileOffsetType '> + metaclassNumSlots := 6. "guess Metaclass instSize" - metaclassSizeBits := 6 * BytesPerWord. "guess (Metaclass instSize * BPW)" swapBytes := self checkImageVersionFrom: f startingAt: imageOffset. headerStart := (self sqImageFilePosition: f) - BytesPerWord. "record header start position" headerSize := self getLongFromFile: f swap: swapBytes. dataSize := self getLongFromFile: f swap: swapBytes. oldBaseAddr := self getLongFromFile: f swap: swapBytes. objectMemory specialObjectsOop: (self getLongFromFile: f swap: swapBytes). objectMemory lastHash: (self getLongFromFile: f swap: swapBytes). "N.B. not used." savedWindowSize := self getLongFromFile: f swap: swapBytes. headerFlags := self getLongFromFile: f swap: swapBytes. self setImageHeaderFlagsFrom: headerFlags. extraVMMemory := self getLongFromFile: f swap: swapBytes. "N.B. not used." hdrNumStackPages := self getShortFromFile: f swap: swapBytes. "4 stack pages is small. Should be able to run with as few as three. 4 should be comfortable but slow. 8 is a reasonable default. Can be changed via vmParameterAt: 43 put: n. Can be set as a preference (Info.plist, VM.ini, command line etc). If desiredNumStackPages is already non-zero then it has been set as a preference. Ignore (but preserve) the header's default." numStackPages := desiredNumStackPages ~= 0 ifTrue: [desiredNumStackPages] ifFalse: [hdrNumStackPages = 0 ifTrue: [self defaultNumStackPages] ifFalse: [hdrNumStackPages]]. desiredNumStackPages := hdrNumStackPages. "This slot holds the size of the native method zone in 1k units. (pad to word boundary)." hdrCogCodeSize := (self getShortFromFile: f swap: swapBytes) * 1024. cogCodeSize := desiredCogCodeSize ~= 0 ifTrue: [desiredCogCodeSize] ifFalse: [hdrCogCodeSize = 0 ifTrue: [self defaultCogCodeSize] ifFalse: [hdrCogCodeSize]]. hdrEdenBytes := self getLongFromFile: f swap: swapBytes. objectMemory edenBytes: (desiredEdenBytes ~= 0 ifTrue: [desiredEdenBytes] ifFalse: [hdrEdenBytes = 0 ifTrue: [objectMemory defaultEdenBytes] ifFalse: [hdrEdenBytes]]). desiredEdenBytes := hdrEdenBytes. hdrMaxExtSemTabSize := self getShortFromFile: f swap: swapBytes. hdrMaxExtSemTabSize ~= 0 ifTrue: [self setMaxExtSemSizeTo: hdrMaxExtSemTabSize]. "pad to word boundary. This slot can be used for anything else that will fit in 16 bits. Preserve it to be polite to other VMs." the2ndUnknownShort := self getShortFromFile: f swap: swapBytes. firstSegSize := self getLongFromFile: f swap: swapBytes. objectMemory firstSegmentSize: firstSegSize. "compare memory requirements with availability" minimumMemory := cogCodeSize "no need to include the stackZone; this is alloca'ed" + dataSize + objectMemory newSpaceBytes + self interpreterAllocationReserveBytes. heapSize := cogCodeSize "no need to include the stackZone; this is alloca'ed" + desiredHeapSize "+ edenBytes" "don't include edenBytes; this is part of the heap and so part of desiredHeapSize" + self interpreterAllocationReserveBytes. heapSize < minimumMemory ifTrue: [self insufficientMemorySpecifiedError]. "allocate a contiguous block of memory for the Squeak heap and ancilliary data structures" objectMemory memory: (self allocateMemory: heapSize minimum: minimumMemory imageFile: f headerSize: headerSize) asUnsignedInteger. objectMemory memory = nil ifTrue: [self insufficientMemoryAvailableError]. heapBase := objectMemory memory + cogCodeSize. self assert: objectMemory startOfMemory = heapBase. objectMemory setHeapBase: heapBase memoryLimit: objectMemory memory + heapSize - 24 "decrease memoryLimit a tad for safety (?!!?!!? eem eem 10/9/2013 15:15)" endOfMemory: heapBase + dataSize. "position file after the header" self sqImageFile: f Seek: headerStart + headerSize. "read in the image in bulk, then swap the bytes if necessary" bytesRead := objectMemory readHeapFromImageFile: f dataBytes: dataSize. bytesRead ~= dataSize ifTrue: [self unableToReadImageError]. self ensureImageFormatIsUpToDate: swapBytes. "compute difference between old and new memory base addresses" bytesToShift := objectMemory memoryBaseForImageRead - oldBaseAddr. self initializeInterpreter: bytesToShift. "adjusts all oops to new location" self initializeCodeGenerator. ^dataSize! Item was changed: ----- Method: CogVMSimulator>>nameOfClass: (in category 'debug support') ----- nameOfClass: classOop + | numSlots | + classNameIndex ifNil: [^'??nil cnidx??']. + numSlots := objectMemory numSlotsOf: classOop. + numSlots = metaclassNumSlots ifTrue: - (objectMemory sizeBitsOf: classOop) = metaclassSizeBits ifTrue: [^(self nameOfClass: (objectMemory fetchPointer: thisClassIndex ofObject: classOop)) , ' class']. + numSlots <= classNameIndex ifTrue: + [^'bad class']. ^self stringOf: (objectMemory fetchPointer: classNameIndex ofObject: classOop)! Item was changed: ----- Method: CogVMSimulator>>shortPrint: (in category 'debug support') ----- shortPrint: oop | name classOop | (objectMemory isImmediate: oop) ifTrue: [(objectMemory isImmediateCharacter: oop) ifTrue: [^ '=$' , (objectMemory characterValueOf: oop) printString , ' (' , (String with: (Character value: (objectMemory characterValueOf: oop))) , ')']. (objectMemory isIntegerObject: oop) ifTrue: [^ '=' , (objectMemory integerValueOf: oop) printString , ' (' , (objectMemory integerValueOf: oop) hex , ')']. ^'= UNKNOWN IMMEDIATE', ' (' , (objectMemory integerValueOf: oop) hex , ')']. (objectMemory addressCouldBeObj: oop) ifFalse: [^(oop bitAnd: objectMemory allocationUnit - 1) ~= 0 ifTrue: [' is misaligned'] ifFalse: [' is not on the heap']]. (objectMemory isFreeObject: oop) ifTrue: [^' is a free chunk of size ', (objectMemory sizeOfFree: oop) printString]. (objectMemory isForwarded: oop) ifTrue: [^' is a forwarded object to ', (objectMemory followForwarded: oop) hex, ' of slot size ', (objectMemory numSlotsOfAny: oop) printString]. classOop := objectMemory fetchClassOfNonImm: oop. + (objectMemory numSlotsOf: classOop) = metaclassNumSlots ifTrue: - (objectMemory sizeBitsOf: classOop) = metaclassSizeBits ifTrue: [^'class ' , (self nameOfClass: oop)]. name := self nameOfClass: classOop. name size = 0 ifTrue: [name := '??']. name = 'String' ifTrue: [^ (self stringOf: oop) printString]. name = 'ByteString' ifTrue: [^ (self stringOf: oop) printString]. name = 'Symbol' ifTrue: [^ '#' , (self stringOf: oop)]. name = 'ByteSymbol' ifTrue: [^ '#' , (self stringOf: oop)]. name = 'Character' ifTrue: "SpurMemoryManager has immediate Characters; ObjectMemory does not" [^ '=' , (Character value: (objectMemory integerValueOf: (objectMemory fetchPointer: 0 ofObject: oop))) printString]. name = 'UndefinedObject' ifTrue: [^ 'nil']. name = 'False' ifTrue: [^ 'false']. name = 'True' ifTrue: [^ 'true']. name = 'Float' ifTrue: [^ '=' , (self dbgFloatValueOf: oop) printString]. (#('Association' 'ReadOnlyVariableBinding' 'VariableBinding') includes: name) ifTrue: [^ '(' , (self shortPrint: (self longAt: oop + BaseHeaderSize)) , ' -> ' , (self longAt: oop + BaseHeaderSize + BytesPerWord) hex8 , ')']. ^(('AEIOU' includes: name first) ifTrue: ['an '] ifFalse: ['a ']), name! Item was added: + ----- Method: Spur32BitMMLECoSimulator>>fetchPointer:ofObject: (in category 'object access') ----- + fetchPointer: fieldIndex ofObject: objOop + self assert: (self isForwarded: objOop) not. + self assert: (fieldIndex >= 0 and: [fieldIndex < (self numSlotsOf: objOop)]). + ^super fetchPointer: fieldIndex ofObject: objOop! Item was added: + ----- Method: Spur32BitMMLESimulator>>fetchPointer:ofObject: (in category 'object access') ----- + fetchPointer: fieldIndex ofObject: objOop + self assert: (self isForwarded: objOop) not. + self assert: (fieldIndex >= 0 and: [fieldIndex < (self numSlotsOfAny: objOop)]). + ^super fetchPointer: fieldIndex ofObject: objOop! Item was added: + ----- Method: SpurContiguousObjStack>>printOn: (in category 'printing') ----- + printOn: aStream + <doNotGenerate> + super printOn: aStream. + top ifNotNil: + [aStream nextPutAll: ' top: '; nextPutAll: top hex]! Item was added: + ----- Method: SpurGenerationScavenger>>forgetUnmarkedRememberedObjects (in category 'gc - global') ----- + forgetUnmarkedRememberedObjects + "Remove all unmarked objects from the remembered set. + This is for global scan-mark GC." + | index | + index := 0. + [index < rememberedSetSize] whileTrue: + [| obj | + obj := rememberedSet at: index. + (manager isMarked: obj) + ifTrue: [index := index + 1] + ifFalse: "unmarked; remove by overwriting with last element." + [manager setIsRememberedOf: obj to: false. + rememberedSetSize := rememberedSetSize - 1. + rememberedSet at: index put: (rememberedSet at: rememberedSetSize)]]. + self assert: rememberedSetSize >= 0! Item was changed: CogClass subclass: #SpurMemoryManager (excessive size, no diff calculated) Item was changed: ----- Method: SpurMemoryManager class>>initialize (in category 'class initialization') ----- initialize "SpurMemoryManager initialize" BitsPerByte := 8. "An obj stack is a stack of objects stored in a hidden root slot, such as the markStack or the ephemeronQueue. It is a linked list of segments, with the hot end at the head of the list. It is a word object. The stack pointer is in ObjStackTopx and 0 means empty. The list goes through ObjStackNextx. We don't want to shrink objStacks, since they're used in GC and its good to keep their memory around. So unused pages + created by popping emptying pages are kept on the ObjStackFreex list. + ObjStackNextx must be the last field for swizzleObjStackAt:." - created by popping emptying pages are kept on the ObjStackFreex list." ObjStackPageSlots := 4092. "+ double header = 16k bytes per page in 32-bits" - ObjStackFixedSlots := 3. ObjStackTopx := 0. + ObjStackMyx := 1. + ObjStackFreex := 2. + ObjStackNextx := 3. + ObjStackFixedSlots := 4. - ObjStackFreex := 1. - ObjStackNextx := 2. ObjStackLimit := ObjStackPageSlots - ObjStackFixedSlots. "There are currently two obj stacks, the mark stack and the ephemeron queue." MarkStackRootIndex := self basicNew classTableRootSlots. EphemeronQueueRootIndex := MarkStackRootIndex + 1. CheckObjectOverwrite := true. "The remap buffer support is for compatibility; Spur doesn't GC during allocation. Eventually this should die." RemapBufferSize := 25. "Extra roots are for plugin support." ExtraRootsSize := 2048 "max. # of external roots"! Item was changed: ----- Method: SpurMemoryManager>>addToFreeList:bytes: (in category 'free space') ----- addToFreeList: freeChunk bytes: chunkBytes | childBytes parent child index | "coInterpreter transcript ensureCr. coInterpreter print: 'freeing '. self printFreeChunk: freeChunk." self assert: (self isFreeObject: freeChunk). self assert: chunkBytes = (self bytesInObject: freeChunk). index := chunkBytes / self allocationUnit. index < self numFreeLists ifTrue: [self storePointer: self freeChunkNextIndex ofFreeChunk: freeChunk withValue: (freeLists at: index). freeLists at: index put: freeChunk. freeListsMask := freeListsMask bitOr: 1 << index. ^self]. + - freeListsMask := freeListsMask bitOr: 1. self storePointer: self freeChunkNextIndex ofFreeChunk: freeChunk withValue: 0; storePointer: self freeChunkParentIndex ofFreeChunk: freeChunk withValue: 0; storePointer: self freeChunkSmallerIndex ofFreeChunk: freeChunk withValue: 0; storePointer: self freeChunkLargerIndex ofFreeChunk: freeChunk withValue: 0. "Large chunk list organized as a tree, each node of which is a list of chunks of the same size. Beneath the node are smaller and larger blocks." parent := 0. child := freeLists at: 0. [child ~= 0] whileTrue: [childBytes := self bytesInObject: child. childBytes = chunkBytes ifTrue: "size match; add to list at node." [self storePointer: self freeChunkNextIndex ofFreeChunk: freeChunk withValue: (self fetchPointer: self freeChunkNextIndex ofObject: child); storePointer: self freeChunkNextIndex ofFreeChunk: child withValue: freeChunk. ^self]. "walk down the tree" parent := child. child := self fetchPointer: (childBytes > chunkBytes ifTrue: [self freeChunkSmallerIndex] ifFalse: [self freeChunkLargerIndex]) ofObject: child]. parent = 0 ifTrue: [self assert: (freeLists at: 0) = 0. freeLists at: 0 put: freeChunk. + freeListsMask := freeListsMask bitOr: 1. ^self]. "insert in tree" self storePointer: self freeChunkParentIndex ofFreeChunk: freeChunk withValue: parent. self storePointer: (childBytes > chunkBytes ifTrue: [self freeChunkSmallerIndex] ifFalse: [self freeChunkLargerIndex]) ofFreeChunk: parent withValue: freeChunk! Item was added: + ----- Method: SpurMemoryManager>>allUnscannedEphemeronsAreActive (in category 'weakness and ephemerality') ----- + allUnscannedEphemeronsAreActive + unscannedEphemerons start to: unscannedEphemerons top - self wordSize do: + [:p| | key | + key := self keyOfEphemeron: (self longAt: p). + ((self isImmediate: key) or: [self isMarked: key]) ifTrue: + [^false]]. + ^true! Item was added: + ----- Method: SpurMemoryManager>>ensureRoomOnObjStackAt: (in category 'obj stacks') ----- + ensureRoomOnObjStackAt: objStackRootIndex + "An obj stack is a stack of objects stored in a hidden root slot, such as + the markStack or the ephemeronQueue. It is a linked list of segments, + with the hot end at the head of the list. It is a word object. The stack + pointer is in ObjStackTopx and 0 means empty. The list goes through + ObjStackNextx. We don't want to shrink objStacks, since they're used + in GC and its good to keep their memory around. So unused pages + created by popping emptying pages are kept on the ObjStackFreex list." + | stackOrNil freeOrNewPage | + stackOrNil := self fetchPointer: objStackRootIndex ofObject: hiddenRootsObj. + (stackOrNil = nilObj + or: [(self fetchPointer: ObjStackTopx ofObject: stackOrNil) >= ObjStackLimit]) ifTrue: + [freeOrNewPage := stackOrNil = nilObj + ifTrue: [0] + ifFalse: [self fetchPointer: ObjStackFreex ofObject: stackOrNil]. + freeOrNewPage ~= 0 + ifTrue: "the free page list is always on the new page." + [self storePointer: ObjStackFreex ofObjStack: stackOrNil withValue: 0] + ifFalse: + [freeOrNewPage := self allocateSlotsInOldSpace: ObjStackPageSlots + format: self wordIndexableFormat + classIndex: self wordSizeClassIndexPun. + freeOrNewPage ifNil: [self error: 'no memory to allocate or extend obj stack']. + self storePointer: ObjStackFreex ofObjStack: freeOrNewPage withValue: 0]. + marking ifTrue: [self setIsMarkedOf: freeOrNewPage to: true]. + self storePointer: ObjStackMyx ofObjStack: freeOrNewPage withValue: objStackRootIndex; + storePointer: ObjStackNextx ofObjStack: freeOrNewPage withValue: (stackOrNil = nilObj ifTrue: [0] ifFalse: [stackOrNil]); + storePointer: ObjStackTopx ofObjStack: freeOrNewPage withValue: 0; + storePointer: objStackRootIndex ofObject: hiddenRootsObj withValue: freeOrNewPage. + self assert: (self isValidObjStackAt: objStackRootIndex). + "Added a new page; now update and answer the relevant cached first page." + ^self updateRootOfObjStack: objStackRootIndex with:freeOrNewPage]. + self assert: (self isValidObjStackAt: objStackRootIndex). + ^stackOrNil! Item was removed: - ----- Method: SpurMemoryManager>>ensureRoomOnObjStackAtIndex: (in category 'obj stacks') ----- - ensureRoomOnObjStackAtIndex: objStackRootIndex - "An obj stack is a stack of objects stored in a hidden root slot, such as - the markStack or the ephemeronQueue. It is a linked list of segments, - with the hot end at the head of the list. It is a word object. The stack - pointer is in ObjStackTopx and 0 means empty. The list goes through - ObjStackNextx. We don't want to shrink objStacks, since they're used - in GC and its good to keep their memory around. So unused pages - created by popping emptying pages are kept on the ObjStackFreex list." - | stackOrNil freeOrNewPage | - stackOrNil := self fetchPointer: objStackRootIndex ofObject: hiddenRootsObj. - (stackOrNil = nilObj - or: [(self fetchPointer: ObjStackTopx ofObject: stackOrNil) >= ObjStackLimit]) ifTrue: - [freeOrNewPage := self fetchPointer: ObjStackFreex ofObject: stackOrNil. - freeOrNewPage ~= 0 - ifTrue: "the free page list is always on the new page." - [self storePointerUnchecked: ObjStackFreex ofObject: stackOrNil withValue: 0] - ifFalse: - [freeOrNewPage := self allocateSlotsInOldSpace: ObjStackPageSlots - format: self wordIndexableFormat - classIndex: self wordSizeClassIndexPun. - freeOrNewPage ifNil: [self error: 'no memory to allocate or extend obj stack']. - self storePointerUnchecked: ObjStackFreex ofObject: freeOrNewPage withValue: 0]. - marking ifTrue: [self setIsMarkedOf: freeOrNewPage to: true]. - self storePointerUnchecked: ObjStackNextx ofObject: freeOrNewPage withValue: stackOrNil; - storePointerUnchecked: ObjStackTopx ofObject: freeOrNewPage withValue: 0; - storePointerUnchecked: objStackRootIndex ofObject: hiddenRootsObj withValue: freeOrNewPage. - self assert: (self isValidObjStackAt: objStackRootIndex). - ^freeOrNewPage]. - self assert: (self isValidObjStackAt: objStackRootIndex). - ^stackOrNil! Item was changed: ----- Method: SpurMemoryManager>>fetchPointer:ofObject: (in category 'object access') ----- fetchPointer: fieldIndex ofObject: objOop - self assert: (self isForwarded: objOop) not. ^self longAt: objOop + self baseHeaderSize + (fieldIndex << self shiftForWord)! Item was added: + ----- Method: SpurMemoryManager>>fireAllUnscannedEphemerons (in category 'weakness and ephemerality') ----- + fireAllUnscannedEphemerons + self assert: (self noUnscannedEphemerons) not. + self assert: self allUnscannedEphemeronsAreActive. + unscannedEphemerons start to: unscannedEphemerons top - self wordSize do: + [:p| + self queueEphemeron: (self longAt: p)]. + coInterpreter forceInterruptCheck! Item was added: + ----- Method: SpurMemoryManager>>freeListsObj (in category 'free space') ----- + freeListsObj + ^self objectAfter: trueObj! Item was added: + ----- Method: SpurMemoryManager>>freeUnmarkedObjectsAndNilUnmarkedWeaklingSlots (in category 'gc - global') ----- + freeUnmarkedObjectsAndNilUnmarkedWeaklingSlots + self checkFreeSpace. + scavenger forgetUnmarkedRememberedObjects. + self allOldSpaceObjectsDo: + [:o| + (self isMarked: o) + ifTrue: + [self setIsMarkedOf: o to: false. + ((self isWeakNonImm: o) + and: [self nilUnmarkedWeaklingSlots: o]) ifTrue: + [coInterpreter signalFinalization: o]] + ifFalse: + [self assert: (self isRemembered: o) not. "scavenger should have clearer this above" + self freeObject: o]]. + self checkFreeSpace! Item was changed: ----- Method: SpurMemoryManager>>globalGarbageCollect (in category 'gc - global') ----- globalGarbageCollect self markObjects. + self freeUnmarkedObjectsAndNilUnmarkedWeaklingSlots. - self freeUnmarkedObjects. self exactFitCompact! Item was added: + ----- Method: SpurMemoryManager>>inactiveOrFailedToDeferScan: (in category 'weakness and ephemerality') ----- + inactiveOrFailedToDeferScan: anEphemeron + "Answer whether an ephemeron is inactive (has a marked key) or, + if active, failed to fit on the unscanned ephemerons stack." + | key | + self assert: (self isEphemeron: anEphemeron). + ((self isImmediate: (key := self keyOfEphemeron: anEphemeron)) + or: [self isMarked: key]) ifTrue: + [^true]. + ^(self pushOnUnscannedEphemeronsStack: anEphemeron) not! Item was changed: ----- Method: SpurMemoryManager>>initializeMarkStack (in category 'gc - global') ----- initializeMarkStack + self ensureRoomOnObjStackAt: MarkStackRootIndex! - self ensureRoomOnObjStackAtIndex: MarkStackRootIndex! Item was changed: ----- Method: SpurMemoryManager>>initializeObjectMemory: (in category 'initialization') ----- initializeObjectMemory: bytesToShift "Initialize object memory variables at startup time. Assume endOfMemory is initially set (by the image-reading code) to the end of the last object in the image. Initialization redefines endOfMemory to be the end of the object allocation area based on the total available memory, but reserving some space for forwarding blocks." "Assume: image reader initializes the following variables: memory memoryLimit specialObjectsOop lastHash " <inline: false> | freeListObj | "Catch mis-initializations leading to bad translations to C" self assert: BaseHeaderSize = self baseHeaderSize. segmentManager adjustSegmentSwizzlesBy: bytesToShift. "image may be at a different address; adjust oops for new location" self adjustAllOopsBy: bytesToShift. segmentManager numSegments > 0 "false if Spur image bootstrap" ifTrue: [specialObjectsOop := segmentManager swizzleObj: specialObjectsOop] ifFalse: [self assert: bytesToShift = 0]. "heavily used special objects" nilObj := self splObj: NilObject. falseObj := self splObj: FalseObject. trueObj := self splObj: TrueObject. "In Cog we insist that nil, true & false are next to each other (Cogit generates tighter conditional branch code as a result). In addition, Spur places the free lists and class table root page immediately following them." self assert: nilObj = newSpaceLimit. self assert: falseObj = (self objectAfter: nilObj). self assert: trueObj = (self objectAfter: falseObj). freeListObj := self objectAfter: trueObj. self reInitializeClassTablePostLoad: (self objectAfter: freeListObj). self initializeFreeSpacePostLoad: freeListObj. + markStack := self swizzleObjStackAt: MarkStackRootIndex. + ephemeronQueue := self swizzleObjStackAt: EphemeronQueueRootIndex. - self swizzleObjStack: MarkStackRootIndex. - self swizzleObjStack: EphemeronQueueRootIndex. segmentManager collapseSegmentsPostSwizzle. self initializeNewSpaceVariables. self initializeOldSpaceFirstFree: freeOldSpaceStart. "initializes endOfMemory, freeStart" "These defaults should depend on machine size; e.g. too small on a powerful laptop, too big on a Pi." growHeadroom := 8*1024*1024. "headroom when growing" shrinkThreshold := 16*1024*1024. "free space before shrinking"! Item was added: + ----- Method: SpurMemoryManager>>isEmptyObjStack: (in category 'obj stacks') ----- + isEmptyObjStack: objStack + self assert: (self isValidObjStack: objStack). + ^0 = (self fetchPointer: ObjStackTopx ofObject: objStack)! Item was added: + ----- Method: SpurMemoryManager>>isValidObjStack: (in category 'obj stacks') ----- + isValidObjStack: objStack + "Answer if the obj stack at objStackRootIndex is valid." + ((self addressCouldBeObj: objStack) + and: [(self numSlotsOf: objStack) = ObjStackPageSlots]) ifFalse: + [objStackInvalidBecause := 'first page not obj or wrong size'. + ^false]. + ^self isValidObjStackPage: objStack + myIndex: (self fetchPointer: ObjStackMyx ofObject: objStack) + firstPage: true! Item was changed: ----- Method: SpurMemoryManager>>isValidObjStackAt: (in category 'obj stacks') ----- isValidObjStackAt: objStackRootIndex "Answer if the obj stack at objStackRootIndex is valid." | stackOrNil | stackOrNil := self fetchPointer: objStackRootIndex ofObject: hiddenRootsObj. ^stackOrNil = nilObj + or: [self isValidObjStackPage: stackOrNil myIndex: objStackRootIndex firstPage: true]! - or: [self isValidObjStackPage: stackOrNil firstPage: true]! Item was removed: - ----- Method: SpurMemoryManager>>isValidObjStackPage:firstPage: (in category 'obj stacks') ----- - isValidObjStackPage: objStackPage firstPage: isFirstPage - "Answer if the obj stack at stackRootIndex is valid." - | freeOrNextPage index | - <inline: false> - (self numSlotsOfAny: objStackPage) ~= ObjStackPageSlots ifTrue: [^false]. - freeOrNextPage := self fetchPointer: ObjStackFreex ofObject: objStackPage. - freeOrNextPage ~= 0 ifTrue: - [isFirstPage ifFalse: [^false]. - (self isValidObjStackPage: freeOrNextPage firstPage: false) ifFalse: - [^false]]. - index := self fetchPointer: ObjStackTopx ofObject: objStackPage. - (index between: 0 and: ObjStackLimit) ifFalse: [^false]. - freeOrNextPage := self fetchPointer: ObjStackNextx ofObject: objStackPage. - ^freeOrNextPage = 0 - or: [self isValidObjStackPage: objStackPage firstPage: false]! Item was added: + ----- Method: SpurMemoryManager>>isValidObjStackPage:myIndex:firstPage: (in category 'obj stacks') ----- + isValidObjStackPage: objStackPage myIndex: myx firstPage: isFirstPage + "Answer if the obj stack at stackRootIndex is valid." + | freeOrNextPage index | + <inline: false> + (self numSlotsOfAny: objStackPage) = ObjStackPageSlots ifFalse: + [objStackInvalidBecause := 'wong num slots'. + ^false]. + isFirstPage ifTrue: + [(myx between: self classTableRootSlots and: self classTableRootSlots + self hiddenRootSlots - 1) ifFalse: + [objStackInvalidBecause := 'myx out of range'. + ^false]. + (self fetchPointer: myx ofObject: hiddenRootsObj) = objStackPage ifFalse: + [objStackInvalidBecause := 'firstPage is not root'. + ^false]]. + myx = (self fetchPointer: ObjStackMyx ofObject: objStackPage) ifFalse: + [objStackInvalidBecause := 'wong myx'. + ^false]. + freeOrNextPage := self fetchPointer: ObjStackFreex ofObject: objStackPage. + freeOrNextPage ~= 0 ifTrue: + [isFirstPage ifFalse: + [objStackInvalidBecause := 'free page on other than first page'. + ^false]. + (self isValidObjStackPage: freeOrNextPage myIndex: myx firstPage: false) ifFalse: + [objStackInvalidBecause := self str: objStackInvalidBecause cat: ' on next page'. + ^false]]. + index := self fetchPointer: ObjStackTopx ofObject: objStackPage. + (index between: 0 and: ObjStackLimit) ifFalse: + [objStackInvalidBecause := 'bad topx'. + ^false]. + freeOrNextPage := self fetchPointer: ObjStackNextx ofObject: objStackPage. + ^freeOrNextPage = 0 + or: [self isValidObjStackPage: freeOrNextPage myIndex: myx firstPage: false]! Item was changed: ----- Method: SpurMemoryManager>>markAccessibleObjects (in category 'gc - global') ----- markAccessibleObjects self assert: self validClassTableRootPages. marking := true. + self cCode: [] "for debugging markAndTrace: set (MarkStackRecord := OrderedCollection new)" + inSmalltalk: [MarkStackRecord ifNotNil: [MarkStackRecord resetTo: 1]]. self markAndTraceObjStack: self markStack andContents: false. self assert: self validClassTableRootPages. self markAndTraceObjStack: self ephemeronQueue andContents: true. self assert: self validClassTableRootPages. + self markAndTrace: self freeListsObj. self markAndTrace: hiddenRootsObj. self markAndTrace: self specialObjectsOop. coInterpreter markAndTraceInterpreterOops: true. self markAndFireEphemerons. marking := false! Item was added: + ----- Method: SpurMemoryManager>>markAllUnscannedEphemerons (in category 'weakness and ephemerality') ----- + markAllUnscannedEphemerons + "After firing the unscanned ephemerons we must scan-mark them. + The wrinkle is that doing so may add more ephemerons to the set." + | ptr | + self assert: (self noUnscannedEphemerons) not. + self assert: self allUnscannedEphemeronsAreActive. + ptr := unscannedEphemerons top - self wordSize. + [ptr >= unscannedEphemerons start] whileTrue: + [| ephemeron key | + key := self keyOfEphemeron: (ephemeron := self longAt: ptr). + self markAndTrace: key; + markAndTrace: ephemeron. + unscannedEphemerons top: unscannedEphemerons top - self wordSize. + ptr < unscannedEphemerons top ifTrue: + ["not the last entry; remove it by overwriting it with the last + ephemeron (which must have been newly added by markAndTrace:)." + self longAt: ptr put: (self longAt: unscannedEphemerons top)]. + ptr := ptr - self wordSize]! Item was added: + ----- Method: SpurMemoryManager>>markAndFireEphemerons (in category 'gc - global') ----- + markAndFireEphemerons + <returnTypeC: #void> + "After the initial scan-mark is complete ephemerons can be processed." + [self noUnscannedEphemerons ifTrue: + [^self]. + self markInactiveEphemerons ifFalse: + [self fireAllUnscannedEphemerons]. + self markAllUnscannedEphemerons] + repeat! Item was changed: ----- Method: SpurMemoryManager>>markAndTrace: (in category 'gc - global') ----- markAndTrace: objOop + "Mark the argument, and all objects reachable from it, and any remaining objects on the mark stack. + Follow forwarding pointers in the scan." - "Mark the argument, and all objects reachable from it, and any remaining objects on the mark stack." <returnTypeC: #void> + | objToScan index field | - | objToScan index key | self assert: (self isNonImmediate: objOop). + "if markAndTrace: is to follow and eliminate forwarding pointers + in its scan it cannot be handed an r-value which is forwarded." + self assert: (self isForwarded: objOop) not. (self isMarked: objOop) ifTrue: + [^self]. - [^nil]. "self setIsMarkedOf: objOop to: false" "for debugging" self setIsMarkedOf: objOop to: true. - ((self isEphemeron: objOop) - and: [(self isNonImmediate: (key := self keyOfEphemeron: objOop)) - and: [(self isMarked: key) not - and: [self pushOnUnscannedEphemeronStack: objOop]]]) ifTrue: - [^self]. "Now scan the object, and any remaining objects on the mark stack." objToScan := objOop. + "To avoid overflowing the mark stack when we encounter large objects, we + push the obj, then its numStrongSlots, and then index the object from the stack." + [| numStrongSlots | + ((self isImmediate: objToScan) + or: [numStrongSlots := self numStrongSlotsOf: objToScan ephemeronInactiveIf: #inactiveOrFailedToDeferScan:. + numStrongSlots > self traceImmediatelySlotLimit]) + ifTrue: "scanning a large object. scan until hitting an unmarked object, then switch to it, if any." + [(self isImmediate: objToScan) + ifTrue: + [index := self integerValueOf: objToScan. + objToScan := self topOfObjStack: markStack] - index := 0. - "It is a bad idea to scan big objects early in the mark phase; pushing all their - referents onto the mark stack is inviting overflow. Instead, defer until later." - [| numSlots | - numSlots := self numStrongSlotsOf: objToScan ephemeronInactiveIf: nil. - numSlots > self traceImmediatelySlotLimit ifTrue: - [(self swapLargeObject: objToScan - ofSlots: numSlots - withSmallerOnObjStackAt: MarkStackRootIndex) ifNotNil: - [:top| - (self isImmediate: top) - ifTrue: "index,large object pair" - [index := self integerValueOf: top. - objToScan := self popObjStackAt: MarkStackRootIndex] ifFalse: + [index := numStrongSlots]. + [index > 0] whileTrue: + [index := index - 1. + field := self fetchPointer: index ofObject: objToScan. + (self isOopForwarded: field) ifTrue: + [field := self followForwarded: field. + self storePointerUnchecked: index ofObject: objToScan withValue: field]. + ((self isImmediate: field) + or: [self isMarked: field]) ifFalse: + [self setIsMarkedOf: field to: true. + (self topOfObjStack: markStack) ~= objToScan ifTrue: + [self push: objToScan onObjStack: markStack]. + self push: (self integerObjectOf: index) onObjStack: markStack. + objToScan := field. + index := -1]]. + index >= 0 ifTrue: "if loop terminated without finding an unmarked referent, switch to top of stack." + [objToScan := self popObjStack: markStack. + objToScan = objOop ifTrue: + [objToScan := self popObjStack: markStack]]] + ifFalse: "scanning a small object. scan, marking, pushing unmarked referents, then switch to the top of the stack." + [index := numStrongSlots. + [index > 0] whileTrue: + [index := index - 1. + field := self fetchPointer: index ofObject: objToScan. + (self isOopForwarded: field) ifTrue: + [field := self followForwarded: field. + self storePointerUnchecked: index ofObject: objToScan withValue: field]. + ((self isImmediate: field) + or: [self isMarked: field]) ifFalse: + [self setIsMarkedOf: field to: true. + self push: field onObjStack: markStack. + numStrongSlots := self numStrongSlotsOf: field ephemeronInactiveIf: #inactiveOrFailedToDeferScan:. + numStrongSlots > self traceImmediatelySlotLimit ifTrue: + [self push: (self integerObjectOf: numStrongSlots) onObjStack: markStack]]]. + objToScan := self popObjStack: markStack]. + objToScan notNil] whileTrue! - [objToScan := top]]]. - self assert: (index between: 0 and: (self numStrongSlotsOf: objToScan ephemeronInactiveIf: nil) - 1). - "The opportunity here is to scan a large object only so far, and push it back on the - stack when the stack appears full. But for the moment we don't code this; it's tricky." - [index < numSlots] whileTrue: - [| field | - field := self fetchPointer: index ofObject: objToScan. - ((self isImmediate: field) or: [self isMarked: field]) ifFalse: - [self setIsMarkedOf: field to: true. - ((self isEphemeron: field) - and: [(self isNonImmediate: (key := self keyOfEphemeron: field)) - and: [(self isMarked: key) not - and: [self pushOnUnscannedEphemeronStack: field]]]) ifFalse: - [self push: field onObjStackAt: MarkStackRootIndex]]. - index := index + 1]. - objToScan := self popObjStackAt: MarkStackRootIndex. - objToScan ifNil: [^self]. - (self isImmediate: objToScan) - ifTrue: - [index := self integerValueOf: objToScan. - objToScan := self popObjStackAt: MarkStackRootIndex] - ifFalse: - [index := 0]] repeat! Item was changed: ----- Method: SpurMemoryManager>>markAndTraceObjStack:andContents: (in category 'obj stacks') ----- markAndTraceObjStack: stackOrNil andContents: markAndTraceContents "An obj stack is a stack of objects stored in a hidden root slot, such as the markStack or the ephemeronQueue. It is a linked list of segments, with the hot end at the head of the list. It is a word object. The stack pointer is in ObjStackTopx and 0 means empty." <returnTypeC: #void> | index field | stackOrNil = nilObj ifTrue: [^self]. self assert: (self numSlotsOfAny: stackOrNil) = ObjStackPageSlots. field := self fetchPointer: ObjStackNextx ofObject: stackOrNil. + field ~= 0 ifTrue: + [self markAndTraceObjStack: field andContents: markAndTraceContents]. - self markAndTraceObjStack: field andContents: markAndTraceContents. markAndTraceContents ifFalse: [^self]. + "There are four fixed slots in an obj stack, and a Topx of 0 indicates empty, so + if there were 6 slots in an oop stack, full would be 2, and the last 0-rel index is 5." - "There are two fixed slots in an obj stack, and a Topx of 0 indicates empty, so - if there were 4 slots in an oop stack, full would be 2, and the last 0-rel index is 3. - Hence the last index is topx + fixed slots - 1, or topx + ObjStackNextx" index := (self fetchPointer: ObjStackTopx ofObject: stackOrNil) + ObjStackNextx. + [index >= ObjStackFixedSlots] whileTrue: - [index > ObjStackNextx] whileTrue: [field := self fetchPointer: index ofObject: stackOrNil. (self isImmediate: field) ifFalse: [self markAndTrace: field]. index := index - 1]! Item was added: + ----- Method: SpurMemoryManager>>markInactiveEphemerons (in category 'weakness and ephemerality') ----- + markInactiveEphemerons + "Go through the unscanned ephemerons, marking the inactive ones, and + removing them from the unscanned ephemerons. Answer if any inactive + ones were found. We cannot fire the ephemerons until all are found to + be active since scan-marking an inactive ephemeron later in the set may + render a previously-observed active ephemeron as inactive." + | foundInactive ptr | + foundInactive := false. + ptr := unscannedEphemerons start. + [ptr < unscannedEphemerons top] whileTrue: + [| ephemeron key | + key := self keyOfEphemeron: (ephemeron := self longAt: ptr). + ((self isImmediate: key) or: [self isMarked: key]) + ifTrue: + [foundInactive := true. + "Now remove the inactive ephemeron from the set, and scan-mark it. + Scan-marking it may add more ephemerons to the set." + unscannedEphemerons top: unscannedEphemerons top - self wordSize. + unscannedEphemerons top > ptr ifTrue: + [self longAt: ptr put: (self longAt: unscannedEphemerons top)]. + self markAndTrace: ephemeron] + ifFalse: + [ptr := ptr + self wordSize]]. + ^foundInactive! Item was added: + ----- Method: SpurMemoryManager>>nilUnmarkedWeaklingSlots: (in category 'weakness and ephemerality') ----- + nilUnmarkedWeaklingSlots: aWeakling + "Nil the unmarked slots in aWeakling and + answer if any unmarked slots were found." + | anyUnmarked | + anyUnmarked := false. + (self numStrongSlotsOf: aWeakling ephemeronInactiveIf: nil) to: (self numSlotsOf: aWeakling) - 1 do: + [:i| | oop | + oop := self fetchPointer: i ofObject: aWeakling. + ((self isImmediate: oop) or: [self isMarked: oop]) ifFalse: + [self storePointerUnchecked: i ofObject: aWeakling withValue: nilObj. + anyUnmarked := true]]. + ^anyUnmarked! Item was added: + ----- Method: SpurMemoryManager>>noUnscannedEphemerons (in category 'weakness and ephemerality') ----- + noUnscannedEphemerons + ^unscannedEphemerons top = unscannedEphemerons start! Item was added: + ----- Method: SpurMemoryManager>>popObjStack: (in category 'obj stacks') ----- + popObjStack: objStack + | topx top nextPage myx | + self assert: (self isValidObjStack: objStack). + topx := self fetchPointer: ObjStackTopx ofObject: objStack. + topx = 0 ifTrue: + [self assert: (self fetchPointer: ObjStackNextx ofObject: objStack) = 0. + self cCode: [] "for debugging markAndTrace: set (MarkStackRecord := OrderedCollection new)" + inSmalltalk: + [MarkStackRecord ifNotNil: + [MarkStackRecord addLast: {#EMPTY. nil}]]. + ^nil]. + topx := topx - 1. + top := self fetchPointer: topx + ObjStackFixedSlots ofObject: objStack. + self cCode: [] "for debugging markAndTrace: set (MarkStackRecord := OrderedCollection new)" + inSmalltalk: + [MarkStackRecord ifNotNil: + [(MarkStackRecord last first = #push and: [MarkStackRecord last last = top]) + ifTrue: [MarkStackRecord removeLast] + ifFalse: [MarkStackRecord addLast: {#pop. top}]]]. + self storePointer: ObjStackTopx ofObject: objStack withValue: topx. + (topx = 0 + and: [(nextPage := self fetchPointer: ObjStackNextx ofObject: objStack) ~= 0]) ifTrue: + [self storePointer: ObjStackFreex ofObject: nextPage withValue: objStack. + myx := self fetchPointer: ObjStackMyx ofObject: objStack. + self updateRootOfObjStack: myx with: nextPage]. + ^top! Item was removed: - ----- Method: SpurMemoryManager>>popObjStackAt: (in category 'obj stacks') ----- - popObjStackAt: objStackRootIndex - self shouldBeImplemented! Item was added: + ----- Method: SpurMemoryManager>>push:onObjStack: (in category 'obj stacks') ----- + push: objOop onObjStack: objStack + | topx | + self assert: (self addressCouldBeOop: objOop). + self assert: (self isValidObjStack: objStack). + (self isImmediate: objOop) ifTrue: + [self assert: objStack = markStack. + self assert: (self addressCouldBeObj: (self topOfObjStack: objStack))]. + self cCode: [] "for debugging markAndTrace: set (MarkStackRecord := OrderedCollection new)" + inSmalltalk: [MarkStackRecord ifNotNil: [MarkStackRecord addLast: {#push. objOop}]]. + topx := self fetchPointer: ObjStackTopx ofObject: objStack. + topx >= ObjStackLimit + ifTrue: + [self push: objOop + onObjStack: (self ensureRoomOnObjStackAt: (self fetchPointer: ObjStackMyx ofObject: objStack))] + ifFalse: + [self storePointer: ObjStackFixedSlots + topx ofObject: objStack withValue: objOop. + self storePointer: ObjStackTopx ofObject: objStack withValue: topx + 1]. + ^objOop! Item was removed: - ----- Method: SpurMemoryManager>>push:onObjStackAt: (in category 'obj stacks') ----- - push: objOop onObjStackAt: objStackRootIndex - | page numEntries | - page := self ensureRoomOnObjStackAtIndex: objStackRootIndex. - numEntries := self fetchPointer: ObjStackTopx ofObject: page. - self assert: numEntries < ObjStackLimit. - numEntries := numEntries + 1. - self storePointerUnchecked: numEntries + ObjStackNextx ofObject: page withValue: objOop; - storePointerUnchecked: ObjStackTopx ofObject: page withValue: numEntries! Item was removed: - ----- Method: SpurMemoryManager>>pushOnUnscannedEphemeronStack: (in category 'weakness and ephemerality') ----- - pushOnUnscannedEphemeronStack: anEphemeron - "Attempt to push anEphemeron on the unscanned ephemerons stack - and answer if the attempt succeeded. Note that the ephemeron - stack overflowing isn't a disaster; it simply means treating the - ephemeron as strong in this GC cycle." - self assert: (self isEphemeron: anEphemeron). - unscannedEphemerons top >= unscannedEphemerons limit ifTrue: - [^false]. - self longAt: unscannedEphemerons top put: anEphemeron. - unscannedEphemerons top: unscannedEphemerons top + self wordSize. - ^true! Item was added: + ----- Method: SpurMemoryManager>>pushOnUnscannedEphemeronsStack: (in category 'weakness and ephemerality') ----- + pushOnUnscannedEphemeronsStack: anEphemeron + "Attempt to push anEphemeron on the unscanned ephemerons stack + and answer if the attempt succeeded. Note that the ephemeron + stack overflowing isn't a disaster; it simply means treating the + ephemeron as strong in this GC cycle." + <inline: false> + self assert: (self isEphemeron: anEphemeron). + unscannedEphemerons top >= unscannedEphemerons limit ifTrue: + [^false]. + self longAt: unscannedEphemerons top put: anEphemeron. + unscannedEphemerons top: unscannedEphemerons top + self wordSize. + ^true! Item was changed: ----- Method: SpurMemoryManager>>queueEphemeron: (in category 'weakness and ephemerality') ----- queueEphemeron: anEphemeron self assert: ((self isNonImmediate: anEphemeron) and: [(self formatOf: anEphemeron) = self ephemeronFormat]). + self push: anEphemeron onObjStack: ephemeronQueue! - self push: anEphemeron onObjStackAt: EphemeronQueueRootIndex! Item was changed: ----- Method: SpurMemoryManager>>stackValue:ofObjStack: (in category 'obj stacks') ----- stackValue: offset ofObjStack: objStackPage + | topx nextPage | - | numEntries nextPage | self assert: offset >= 0. + topx := self fetchPointer: ObjStackTopx ofObject: objStackPage. + offset < topx ifTrue: - numEntries := self fetchPointer: ObjStackTopx ofObject: objStackPage. - offset < numEntries ifTrue: [^self fetchPointer: ObjStackTopx + offset ofObject: objStackPage]. nextPage := self fetchPointer: ObjStackNextx ofObject: objStackPage. nextPage = 0 ifTrue: [^nil]. + ^self stackValue: offset - topx ofObjStack: nextPage! - ^self stackValue: offset - numEntries ofObjStack: nextPage! Item was added: + ----- Method: SpurMemoryManager>>stackValue:ofObjStack:put: (in category 'obj stacks') ----- + stackValue: offset ofObjStack: objStackPage put: aValue + | topx nextPage | + self assert: offset >= 0. + topx := self fetchPointer: ObjStackTopx ofObject: objStackPage. + offset < topx ifTrue: + [^self storePointer: ObjStackTopx + offset ofObjStack: objStackPage withValue: aValue]. + nextPage := self fetchPointer: ObjStackNextx ofObject: objStackPage. + nextPage = 0 ifTrue: + [self error: 'no such element on obj stack']. + ^self stackValue: offset - topx ofObjStack: nextPage put: aValue! Item was removed: - ----- Method: SpurMemoryManager>>stackValue:ofObjStackAt: (in category 'obj stacks') ----- - stackValue: offset ofObjStackAt: objStackRootIndex - ^self - stackValue: offset - ofObjStack: (self fetchPointer: objStackRootIndex ofObject: hiddenRootsObj)! Item was added: + ----- Method: SpurMemoryManager>>storePointer:ofObjStack:withValue: (in category 'object access') ----- + storePointer: fieldIndex ofObjStack: objOop withValue: valuePointer + self assert: (self formatOf: objOop) = self wordIndexableFormat. + ^self + longAt: objOop + self baseHeaderSize + (fieldIndex << self shiftForWord) + put: valuePointer! Item was removed: - ----- Method: SpurMemoryManager>>swapLargeObject:ofSlots:withSmallerOnObjStackAt: (in category 'obj stacks') ----- - swapLargeObject: objOop ofSlots: numStrongSlots withSmallerOnObjStackAt: objStackRootIndex - "Assuming objOop is large, answer a smaller object, if it is available, otherwise answer nil." - | objStackPage top topObj | - objStackPage := self fetchPointer: objStackRootIndex ofObject: hiddenRootsObj. - top := self stackValue: 0 ofObjStack: objStackPage. - top ifNil: [^nil]. - (self isImmediate: top) ifTrue: "index,large obj pair on top. is it smaller?" - [(self integerValueOf: top) >= numStrongSlots ifTrue: - [^nil]. "no. go with the one we've already got" - "yes. push 0, objOop, answer index, leaving large obj on top to be popped." - topObj := self stackValue: 1 ofObjStack: objStackPage. - self stackValue: 0 ofObjStackAt: objStackRootIndex put: ConstZero. - self stackValue: 1 ofObjStackAt: objStackRootIndex put: objOop. - self push: topObj onObjStackAt: objStackRootIndex. - ^top]. - "push numStrongSlots, objOop and answer top" - self stackValue: 0 ofObjStackAt: objStackRootIndex put: objOop. - self push: ConstZero onObjStackAt: objStackRootIndex. - ^top! Item was removed: - ----- Method: SpurMemoryManager>>swizzleObjStack: (in category 'obj stacks') ----- - swizzleObjStack: objStackRootIndex - <returnTypeC: #void> - "On load, swizzle the pointers in an obj stack." - | firstPage stackOrNil index field | - firstPage := stackOrNil := self fetchPointer: objStackRootIndex ofObject: hiddenRootsObj. - stackOrNil = nilObj ifTrue: - [^self]. - [self assert: (self numSlotsOfAny: stackOrNil) = ObjStackPageSlots. - "There are three fixed slots in an obj stack, and a Topx of 0 indicates empty, so - if there were 5 slots in an oop stack, full would be 2, and the last 0-rel index is 4. - Hence the last index is topx + fixed slots - 1, or topx + ObjStackNextx" - index := (self fetchPointer: ObjStackTopx ofObject: stackOrNil) + ObjStackNextx. - [field := self fetchPointer: index ofObject: stackOrNil. - (self isImmediate: field) ifFalse: - [field := segmentManager swizzleObj: field. - self storePointerUnchecked: ObjStackNextx ofObject: stackOrNil withValue: field]. - (index := index - 1) > ObjStackTopx] whileTrue. - (stackOrNil := field) ~= 0] whileTrue. - [stackOrNil := self fetchPointer: ObjStackFreex ofObject: firstPage. - stackOrNil ~= 0] whileTrue: - [field := segmentManager swizzleObj: stackOrNil. - self storePointerUnchecked: ObjStackFreex ofObject: firstPage withValue: field. - firstPage := stackOrNil]. - self assert: (self isValidObjStackAt: objStackRootIndex) - ! Item was added: + ----- Method: SpurMemoryManager>>swizzleObjStackAt: (in category 'obj stacks') ----- + swizzleObjStackAt: objStackRootIndex + <returnTypeC: #void> + "On load, swizzle the pointers in an obj stack. Answer the obj stack's oop." + | firstPage stackOrNil index field | + firstPage := stackOrNil := self fetchPointer: objStackRootIndex ofObject: hiddenRootsObj. + stackOrNil = nilObj ifTrue: + [^stackOrNil]. + [self assert: (self numSlotsOfAny: stackOrNil) = ObjStackPageSlots. + self assert: (self fetchPointer: ObjStackMyx ofObject: stackOrNil) = objStackRootIndex. + "There are four fixed slots in an obj stack, and a Topx of 0 indicates empty, so + if there were 5 slots in an oop stack, full would be 2, and the last 0-rel index is 4. + Hence the last index is topx + fixed slots - 1, or topx + ObjStackNextx" + index := (self fetchPointer: ObjStackTopx ofObject: stackOrNil) + ObjStackNextx. + "swizzle fields including ObjStackNextx and leave field containing the next link." + [field := self fetchPointer: index ofObject: stackOrNil. + (self isImmediate: field) ifFalse: + [field := segmentManager swizzleObj: field. + self storePointer: ObjStackNextx ofObjStack: stackOrNil withValue: field]. + (index := index - 1) > ObjStackTopx] whileTrue. + (stackOrNil := field) ~= 0] whileTrue. + [stackOrNil := self fetchPointer: ObjStackFreex ofObject: firstPage. + stackOrNil ~= 0] whileTrue: + [field := segmentManager swizzleObj: stackOrNil. + self storePointer: ObjStackFreex ofObjStack: firstPage withValue: field. + firstPage := stackOrNil]. + self assert: (self isValidObjStackAt: objStackRootIndex) + ! Item was added: + ----- Method: SpurMemoryManager>>topOfObjStack: (in category 'obj stacks') ----- + topOfObjStack: objStack + | topx | + self assert: (self isValidObjStack: objStack). + topx := self fetchPointer: ObjStackTopx ofObject: objStack. + topx = 0 ifTrue: + [self assert: (self fetchPointer: ObjStackNextx ofObject: objStack) = 0. + ^nil]. + ^self fetchPointer: topx + ObjStackFixedSlots - 1 ofObject: objStack! Item was added: + ----- Method: SpurMemoryManager>>updateRootOfObjStack:with: (in category 'obj stacks') ----- + updateRootOfObjStack: objStackRootIndex with: newRootPage + self assert: (self isValidObjStack: newRootPage). + objStackRootIndex caseOf: { + [MarkStackRootIndex] -> [markStack := newRootPage]. + [EphemeronQueueRootIndex] -> [ephemeronQueue := newRootPage] }. + ^newRootPage! Item was changed: InterpreterPrimitives subclass: #StackInterpreter + instanceVariableNames: 'currentBytecode bytecodeSetSelector localFP localIP localSP stackLimit stackPage stackPages method instructionPointer stackPointer framePointer localReturnValue extA extB primitiveFunctionPointer methodCache atCache lkupClassTag lkupClass methodDictLinearSearchLimit highestRunnableProcessPriority nextWakeupUsecs nextPollUsecs inIOProcessEvents interruptKeycode interruptPending savedWindowSize imageHeaderFlags fullScreenFlag deferDisplayUpdates pendingFinalizationSignals extraVMMemory interpreterProxy showSurfaceFn primitiveTable externalPrimitiveTable externalPrimitiveTableFirstFreeIndex overflowedPage extraFramesToMoveOnOverflow globalSessionID jmpBuf jmpDepth suspendedCallbacks suspendedMethods numStackPages desiredNumStackPages desiredEdenBytes classNameIndex thisClassIndex metaclassNumSlots interruptCheckChain suppressHeartbeatFlag breakSelector breakSelectorLength longRunningPrimitiveCheckMethod longRunningPrimitiveCheckSemaphore longRunningPrimitiveStartUsecs longRunningPrimitiveStopUsecs longRunningPrimitiveGCUsecs longRunningPrimitiveCheckSequenceNumber longRunningPrimitiveSignalUndelivered tempOop statForceInterruptCheck statStackOverflow statStackPageDivorce statCheckForEvents statProcessSwitch statIOProcessEvents theUnknownShort the2ndUnknownShort imageFloatsBigEndian maxExtSemTabSizeSet lastMethodCacheProbeWrite statPendingFinalizationSignals gcSemaphoreIndex classByteArrayCompactIndex' - instanceVariableNames: 'currentBytecode bytecodeSetSelector localFP localIP localSP stackLimit stackPage stackPages method instructionPointer stackPointer framePointer localReturnValue extA extB primitiveFunctionPointer methodCache atCache lkupClassTag lkupClass methodDictLinearSearchLimit highestRunnableProcessPriority nextWakeupUsecs nextPollUsecs inIOProcessEvents interruptKeycode interruptPending savedWindowSize imageHeaderFlags fullScreenFlag deferDisplayUpdates pendingFinalizationSignals extraVMMemory interpreterProxy showSurfaceFn primitiveTable externalPrimitiveTable externalPrimitiveTableFirstFreeIndex overflowedPage extraFramesToMoveOnOverflow globalSessionID jmpBuf jmpDepth suspendedCallbacks suspendedMethods numStackPages desiredNumStackPages desiredEdenBytes classNameIndex thisClassIndex metaclassSizeBits interruptCheckChain suppressHeartbeatFlag breakSelector breakSelectorLength longRunningPrimitiveCheckMethod longRunningPrimitiveCheckSemaphore longRunningPrimitiveStartUsecs longRunningPrimitiveStopUsecs longRunningPrimitiveGCUsecs longRunningPrimitiveCheckSequenceNumber longRunningPrimitiveSignalUndelivered tempOop statForceInterruptCheck statStackOverflow statStackPageDivorce statCheckForEvents statProcessSwitch statIOProcessEvents theUnknownShort the2ndUnknownShort imageFloatsBigEndian maxExtSemTabSizeSet lastMethodCacheProbeWrite statPendingFinalizationSignals gcSemaphoreIndex classByteArrayCompactIndex' classVariableNames: 'AtCacheEntries AtCacheFixedFields AtCacheFmt AtCacheMask AtCacheOop AtCacheSize AtCacheTotalSize AtPutBase BytecodeTable CacheProbeMax DirBadPath DirEntryFound DirNoMoreEntries DumpStackOnLowSpace EnclosingMixinIndex EnclosingObjectIndex FailImbalancedPrimitives HeaderFlagBitPosition MaxExternalPrimitiveTableSize MaxJumpBuf MaxPrimitiveIndex MaxQuickPrimitiveIndex MixinIndex PrimitiveExternalCallIndex PrimitiveTable' poolDictionaries: 'VMBasicConstants VMMethodCacheConstants VMObjectIndices VMSpurObjectRepresentationConstants VMSqueakClassIndices VMSqueakV3BytecodeConstants VMSqueakV3ObjectRepresentationConstants VMStackFrameOffsets' category: 'VMMaker-Interpreter'! !StackInterpreter commentStamp: 'eem 9/11/2013 18:30' prior: 0! This class is a complete implementation of the Smalltalk-80 virtual machine, derived originally from the Blue Book specification but quite different in some areas. This VM supports Closures but *not* old-style BlockContexts. It has been modernized with 32-bit pointers, better management of Contexts (see next item), and attention to variable use that allows the CCodeGenerator (qv) to keep, eg, the instruction pointer and stack pointer in registers as well as keeping most simple variables in a global array that seems to improve performance for most platforms. The VM does not use Contexts directly. Instead Contexts serve as proxies for a more conventional stack format that is invisible to the image. There is considerable explanation at http://www.mirandabanda.org/cogblog/2009/01/14/under-cover-contexts-and-the…. The VM maintains a fixed-size stack zone divided into pages, each page being capable of holding several method/block activations. A send establishes a new frame in the current stack page, a return returns to the previous frame. This eliminates allocation/deallocation of contexts and the moving of receiver and arguments from caller to callee on each send/return. Contexts are created lazily when an activation needs a context (creating a block, explicit use of thisContext, access to sender when sender is a frame, or linking of stack pages together). Contexts are either conventional and heap-resident ("single") or "married" and serve as proxies for their corresponding frame or "widowed", meaning that their spouse frame has been returned from (died). A married context is specially marked (more details in the code) and refers to its frame. Likewise a married frame is specially marked and refers to its context. In addition to SmallInteger arithmetic and Floats, the VM supports logic on 32-bit PositiveLargeIntegers, thus allowing it to simulate itself much more effectively than would otherwise be the case. NOTE: Here follows a list of things to be borne in mind when working on this code, or when making changes for the future. 1. There are a number of things that should be done the next time we plan to release a completely incompatible image format. These include unifying the instanceSize field of the class format word -- see instantiateClass:indexableSize:, and unifying the bits of the method primitive index (if we decide we need more than 512, after all) -- see primitiveIndexOf:. Also, contexts should be given a special format code (see next item). 2. There are several fast checks for contexts (see isContextHeader: and isMethodContextHeader:) which will fail if the compact class indices of BlockContext or MethodContext change. This is necessary because the oops may change during a compaction when the oops are being adjusted. It's important to be aware of this when writing a new image using the SystemTracer. A better solution would be to reserve one of the format codes for Contexts only. An even better solution is to eliminate compact classes altogether (see 6.). 3. We have made normal files tolerant to size and positions up to 32 bits. This has not been done for async files, since they are still experimental. The code in size, at: and at:put: should work with sizes and indices up to 31 bits, although I have not tested it (di 12/98); it might or might not work with 32-bit sizes. [Late news, the support has been extended to 64-bit file sizes]. 4. Note that 0 is used in a couple of places as an impossible oop. This should be changed to a constant that really is impossible (or perhaps there is code somewhere that guarantees it --if so it should be put in this comment). The places include the method cache and the at cache. 5. Moving to a 2 bit immediate tag and having immediate Characters is a good choice for Unicode and the JIT. We can still have 31-bit SmallIntegers by allowing two tag patterns for SmallInteger. 6. If Eliot Miranda's 2 word header scheme is acceptable in terms of footprint (we estimate about a 10% increase in image size with about 35 reclaimed by better representation of CompiledMethod - loss of MethodProperties) then the in-line cache for the JIT is simplified, class access is faster and header access is the same in 32-bit and full 64-bit images. [Late breaking news, the 2-word header scheme is more compact, by over 2%]. See SpurMemorymanager's class comment.! Item was changed: ----- Method: StackInterpreter>>initializeExtraClassInstVarIndices (in category 'initialization') ----- initializeExtraClassInstVarIndices + "Initialize metaclassNumSlots and thisClassIndex which are used in debug printing, and - "Initialize metaclassSizeBits and thisClassIndex which are used in debug printing, and classNameIndex which is used not only for debug printing but for is:KindOf: & is:MemberOf: via classNameOf:is: (evil but a reality we have to accept)." | classArrayObj classArrayClass | classArrayObj := objectMemory splObj: ClassArray. classArrayClass := objectMemory fetchClassOfNonImm: classArrayObj. + metaclassNumSlots := objectMemory numSlotsOf: classArrayClass. "determine actual Metaclass instSize" - metaclassSizeBits := objectMemory sizeBitsOf: classArrayClass. "determine actual (Metaclass instSize * 4)" thisClassIndex := 5. "default" InstanceSpecificationIndex + 1 to: (objectMemory lengthOf: classArrayClass) do: [:i| (objectMemory fetchPointer: i - 1 ofObject: classArrayClass) = classArrayObj ifTrue: [thisClassIndex := i - 1]]. classNameIndex := 6. "default" InstanceSpecificationIndex + 1 to: (objectMemory lengthOf: classArrayObj) do: [:i| | oop | oop := objectMemory fetchPointer: i - 1 ofObject: classArrayObj. ((objectMemory isBytes: oop) and: [(objectMemory lengthOf: oop) = 5 and: [(self str: 'Array' n: (objectMemory firstFixedField: oop) cmp: 5) = 0]]) ifTrue: [classNameIndex := i - 1]]! Item was changed: ----- Method: StackInterpreter>>lengthOfNameOfClass: (in category 'debug printing') ----- lengthOfNameOfClass: classOop <inline: false> + | numSlots | + numSlots := objectMemory numSlotsOf: classOop. + numSlots = metaclassNumSlots ifTrue: - (objectMemory sizeBitsOf: classOop) = metaclassSizeBits ifTrue: [^self lengthOfNameOfClass: (objectMemory fetchPointer: thisClassIndex ofObject: classOop)]. + numSlots <= classNameIndex ifTrue: + [^0]. ^objectMemory lengthOf: (objectMemory fetchPointer: classNameIndex ofObject: classOop)! Item was changed: ----- Method: StackInterpreter>>nameOfClass: (in category 'debug printing') ----- nameOfClass: classOop "Brain-damaged nameOfClass: for C VM. Does *not* answer Foo class for metaclasses. Use e.g. classIsMeta: to avoid being fooled." <inline: false> <returnTypeC: 'char *'> + | numSlots | + numSlots := objectMemory numSlotsOf: classOop. + numSlots = metaclassNumSlots ifTrue: - (objectMemory sizeBitsOf: classOop) = metaclassSizeBits ifTrue: [^self nameOfClass: (objectMemory fetchPointer: thisClassIndex ofObject: classOop)]. + numSlots <= classNameIndex ifTrue: + [^'bad class']. ^objectMemory firstFixedField: (objectMemory fetchPointer: classNameIndex ofObject: classOop)! Item was changed: ----- Method: StackInterpreter>>printNameOfClass:count: (in category 'debug printing') ----- printNameOfClass: classOop count: cnt "Details: The count argument is used to avoid a possible infinite recursion if classOop is a corrupted object." <inline: false> + | numSlots | classNameIndex ifNil: [self print: '??nil cnidx??'. ^self]. (classOop isNil or: [classOop = 0 or: [cnt <= 0]]) ifTrue: [^self print: 'bad class']. + numSlots := objectMemory numSlotsOf: classOop. + (numSlots = metaclassNumSlots + and: [metaclassNumSlots > thisClassIndex]) - ((objectMemory sizeBitsOf: classOop) = metaclassSizeBits - and: [metaclassSizeBits > (thisClassIndex * BytesPerOop)]) "(Metaclass instSize * 4)" ifTrue: [self printNameOfClass: (objectMemory fetchPointer: thisClassIndex ofObject: classOop) count: cnt - 1. self print: ' class'] + ifFalse: + [numSlots <= classNameIndex + ifTrue: [self print: 'bad class'] + ifFalse: + [self printStringOf: (objectMemory fetchPointer: classNameIndex ofObject: classOop)]]! - ifFalse: [self printStringOf: (objectMemory fetchPointer: classNameIndex ofObject: classOop)]! Item was changed: ----- Method: StackInterpreter>>printOopShortInner: (in category 'debug printing') ----- printOopShortInner: oop | classOop name nameLen | <var: #name type: #'char *'> <inline: true> (objectMemory isImmediate: oop) ifTrue: [(objectMemory isImmediateCharacter: oop) ifTrue: [self printChar: $$; printChar: (objectMemory characterValueOf: oop); printChar: $(; printHex: (objectMemory integerValueOf: oop); printChar: $). ^nil]. self printNum: (objectMemory integerValueOf: oop); printChar: $(; printHex: (objectMemory integerValueOf: oop); printChar: $). ^nil]. (objectMemory addressCouldBeObj: oop) ifFalse: [self print: ((oop bitAnd: objectMemory allocationUnit - 1) ~= 0 ifTrue: [' is misaligned'] ifFalse: [' is not on the heap']); cr. ^nil]. (self isFloatObject: oop) ifTrue: [self printFloat: (self dbgFloatValueOf: oop). ^nil]. classOop := objectMemory fetchClassOfNonImm: oop. (objectMemory addressCouldBeObj: classOop) ifFalse: [self print: 'a ??'. ^nil]. + (objectMemory numSlotsOf: classOop) = metaclassNumSlots ifTrue: - (objectMemory sizeBitsOf: classOop) = metaclassSizeBits ifTrue: [self printNameOfClass: oop count: 5. ^nil]. oop = objectMemory nilObject ifTrue: [self print: 'nil'. ^nil]. oop = objectMemory trueObject ifTrue: [self print: 'true'. ^nil]. oop = objectMemory falseObject ifTrue: [self print: 'false'. ^nil]. nameLen := self lengthOfNameOfClass: classOop. nameLen = 0 ifTrue: [self print: 'a ??'. ^nil]. name := self nameOfClass: classOop. nameLen = 10 ifTrue: [(self str: name n: 'ByteString' cmp: 10) not "strncmp is weird" ifTrue: [self printChar: $'; printStringOf: oop; printChar: $'. ^nil]. (self str: name n: 'ByteSymbol' cmp: 10) not "strncmp is weird" ifTrue: [self printChar: $#; printStringOf: oop. ^nil]]. (nameLen = 9 and: [(self str: name n: 'Character' cmp: 9) not]) ifTrue: [self printChar: $$; printChar: (objectMemory integerValueOf: (objectMemory fetchPointer: 0 ofObject: oop)). ^nil]. self print: 'a(n) '. 1 to: nameLen do: [:i| self printChar: (name at: i)]. "Try to spot association-like things; they're all subclasses of LookupKey" ((objectMemory instanceSizeOf: classOop) = (ValueIndex + 1) and: [(self superclassOf: classOop) = (self superclassOf: (objectMemory fetchClassOfNonImm: (objectMemory splObj: SchedulerAssociation))) and: [objectMemory isBytes: (objectMemory fetchPointer: KeyIndex ofObject: oop)]]) ifTrue: [self space; printOopShort: (objectMemory fetchPointer: KeyIndex ofObject: oop); print: ' -> '; printHex: (objectMemory fetchPointer: ValueIndex ofObject: oop)]! Item was changed: ----- Method: StackInterpreter>>readImageFromFile:HeapSize:StartingAt: (in category 'image save/restore') ----- readImageFromFile: f HeapSize: desiredHeapSize StartingAt: imageOffset "Read an image from the given file stream, allocating the given amount of memory to its object heap. Fail if the image has an unknown format or requires more than the given amount of memory." "Details: This method detects when the image was stored on a machine with the opposite byte ordering from this machine and swaps the bytes automatically. Furthermore, it allows the header information to start 512 bytes into the file, since some file transfer programs for the Macintosh apparently prepend a Mac-specific header of this size. Note that this same 512 bytes of prefix area could also be used to store an exec command on Unix systems, allowing one to launch Smalltalk by invoking the image name as a command." "This code is based on C code by Ian Piumarta and Smalltalk code by Tim Rowledge. Many thanks to both of you!!!!" | swapBytes headerStart headerSize dataSize oldBaseAddr hdrNumStackPages minimumMemory heapBase bytesRead bytesToShift heapSize hdrEdenBytes headerFlags hdrMaxExtSemTabSize firstSegSize | <var: #f type: 'sqImageFile '> <var: #heapBase type: 'usqInt'> <var: #desiredHeapSize type: 'usqInt'> <var: #headerStart type: 'squeakFileOffsetType '> <var: #dataSize type: 'size_t '> <var: #imageOffset type: 'squeakFileOffsetType '> + metaclassNumSlots := 6. "guess Metaclass instSize" - metaclassSizeBits := 6 * BytesPerWord. "guess (Metaclass instSize * BPW)" swapBytes := self checkImageVersionFrom: f startingAt: imageOffset. headerStart := (self sqImageFilePosition: f) - BytesPerWord. "record header start position" headerSize := self getLongFromFile: f swap: swapBytes. dataSize := self getLongFromFile: f swap: swapBytes. oldBaseAddr := self getLongFromFile: f swap: swapBytes. objectMemory specialObjectsOop: (self getLongFromFile: f swap: swapBytes). objectMemory lastHash: (self getLongFromFile: f swap: swapBytes). "N.B. not used." savedWindowSize := self getLongFromFile: f swap: swapBytes. headerFlags := self getLongFromFile: f swap: swapBytes. self setImageHeaderFlagsFrom: headerFlags. extraVMMemory := self getLongFromFile: f swap: swapBytes. hdrNumStackPages := self getShortFromFile: f swap: swapBytes. "4 stack pages is small. Should be able to run with as few as three. 4 should be comfortable but slow. 8 is a reasonable default. Can be changed via vmParameterAt: 43 put: n. Can be set as a preference (Info.plist, VM.ini, command line etc). If desiredNumStackPages is already non-zero then it has been set as a preference. Ignore (but preserve) the header's default." numStackPages := desiredNumStackPages ~= 0 ifTrue: [desiredNumStackPages] ifFalse: [hdrNumStackPages = 0 ifTrue: [self defaultNumStackPages] ifFalse: [hdrNumStackPages]]. desiredNumStackPages := hdrNumStackPages. "pad to word boundary. This slot can be used for anything else that will fit in 16 bits. It is used for the cog code size in Cog. Preserve it to be polite to other VMs." theUnknownShort := self getShortFromFile: f swap: swapBytes. hdrEdenBytes := self getLongFromFile: f swap: swapBytes. objectMemory edenBytes: (desiredEdenBytes ~= 0 ifTrue: [desiredEdenBytes] ifFalse: [hdrEdenBytes = 0 ifTrue: [objectMemory defaultEdenBytes] ifFalse: [hdrEdenBytes]]). desiredEdenBytes := hdrEdenBytes. hdrMaxExtSemTabSize := self getShortFromFile: f swap: swapBytes. hdrMaxExtSemTabSize ~= 0 ifTrue: [self setMaxExtSemSizeTo: hdrMaxExtSemTabSize]. "pad to word boundary. This slot can be used for anything else that will fit in 16 bits. Preserve it to be polite to other VMs." the2ndUnknownShort := self getShortFromFile: f swap: swapBytes. firstSegSize := self getLongFromFile: f swap: swapBytes. objectMemory firstSegmentSize: firstSegSize. "decrease Squeak object heap to leave extra memory for the VM" heapSize := self cCode: 'reserveExtraCHeapBytes(desiredHeapSize, extraVMMemory)'. "compare memory requirements with availability". minimumMemory := dataSize + objectMemory newSpaceBytes + self interpreterAllocationReserveBytes. heapSize < minimumMemory ifTrue: [self insufficientMemorySpecifiedError]. "allocate a contiguous block of memory for the Squeak heap" objectMemory memory: (self allocateMemory: heapSize minimum: minimumMemory imageFile: f headerSize: headerSize) asUnsignedInteger. objectMemory memory = nil ifTrue: [self insufficientMemoryAvailableError]. heapBase := objectMemory startOfMemory. objectMemory setHeapBase: heapBase memoryLimit: (heapBase + heapSize) - 24 "decrease memoryLimit a tad for safety" endOfMemory: heapBase + dataSize. "position file after the header" self sqImageFile: f Seek: headerStart + headerSize. "read in the image in bulk, then swap the bytes if necessary" bytesRead := objectMemory readHeapFromImageFile: f dataBytes: dataSize. bytesRead ~= dataSize ifTrue: [self unableToReadImageError]. self ensureImageFormatIsUpToDate: swapBytes. "compute difference between old and new memory base addresses" bytesToShift := objectMemory memoryBaseForImageRead - oldBaseAddr. self initializeInterpreter: bytesToShift. "adjusts all oops to new location" ^dataSize! Item was changed: ----- Method: StackInterpreterSimulator>>nameOfClass: (in category 'debug support') ----- nameOfClass: classOop + | numSlots | classNameIndex ifNil: [^'??nil cnidx??']. + numSlots := objectMemory numSlotsOf: classOop. + numSlots = metaclassNumSlots ifTrue: - (objectMemory sizeBitsOf: classOop) = metaclassSizeBits ifTrue: [^(self nameOfClass: (objectMemory fetchPointer: thisClassIndex ofObject: classOop)) , ' class']. + numSlots <= classNameIndex ifTrue: + [^'bad class']. ^self stringOf: (objectMemory fetchPointer: classNameIndex ofObject: classOop)! Item was changed: ----- Method: StackInterpreterSimulator>>shortPrint: (in category 'debug support') ----- shortPrint: oop | name classOop | (objectMemory isImmediate: oop) ifTrue: [(objectMemory isImmediateCharacter: oop) ifTrue: [^ '=$' , (objectMemory characterValueOf: oop) printString , ' (' , (String with: (Character value: (objectMemory characterValueOf: oop))) , ')']. (objectMemory isIntegerObject: oop) ifTrue: [^ '=' , (objectMemory integerValueOf: oop) printString , ' (' , (objectMemory integerValueOf: oop) hex , ')']. ^'= UNKNOWN IMMEDIATE', ' (' , (objectMemory integerValueOf: oop) hex , ')']. (objectMemory addressCouldBeObj: oop) ifFalse: [^(oop bitAnd: objectMemory allocationUnit - 1) ~= 0 ifTrue: [' is misaligned'] ifFalse: [' is not on the heap']]. (objectMemory isFreeObject: oop) ifTrue: [^' is a free chunk of size ', (objectMemory sizeOfFree: oop) printString]. (objectMemory isForwarded: oop) ifTrue: [^' is a forwarded object to ', (objectMemory followForwarded: oop) hex, ' of slot size ', (objectMemory numSlotsOfAny: oop) printString]. classOop := objectMemory fetchClassOfNonImm: oop. + (objectMemory numSlotsOf: classOop) = metaclassNumSlots ifTrue: - (objectMemory sizeBitsOf: classOop) = metaclassSizeBits ifTrue: [^'class ' , (self nameOfClass: oop)]. name := self nameOfClass: classOop. name size = 0 ifTrue: [name := '??']. name = 'String' ifTrue: [^ (self stringOf: oop) printString]. name = 'ByteString' ifTrue: [^ (self stringOf: oop) printString]. name = 'Symbol' ifTrue: [^ '#' , (self stringOf: oop)]. name = 'ByteSymbol' ifTrue: [^ '#' , (self stringOf: oop)]. name = 'Character' ifTrue: "SpurMemoryManager has immediate Characters; ObjectMemory does not" [^ '=' , (Character value: (objectMemory integerValueOf: (objectMemory fetchPointer: 0 ofObject: oop))) printString]. name = 'UndefinedObject' ifTrue: [^ 'nil']. name = 'False' ifTrue: [^ 'false']. name = 'True' ifTrue: [^ 'true']. name = 'Float' ifTrue: [^ '=' , (self dbgFloatValueOf: oop) printString]. (#('Association' 'ReadOnlyVariableBinding' 'VariableBinding') includes: name) ifTrue: [^ '(' , (self shortPrint: (self longAt: oop + BaseHeaderSize)) , ' -> ' , (self longAt: oop + BaseHeaderSize + BytesPerWord) hex8 , ')']. ^(('AEIOU' includes: name first) ifTrue: ['an '] ifFalse: ['a ']), name!

1 0

VM download location confusion
by tim Rowledge 18 Oct '13

18 Oct '13

We have a fairly confusing story for downloading VMs at the moment, at least so far as I can see. I'm particularly referring to Mac VMs here, since I don't have any idea what the situation with Windows VMs might be. squeakvm.org/mac points to a cog vm that seems to date itself to 2010, or to an autobuilder for the pharo group at inria (which won't respond to me anyway). Eliot's blog site has a quite separate download folder. There's the jenkins autobuilder at build.squeak.org as well, of course. We should probably have a better story than that. tim -- tim Rowledge; tim(a)rowledge.org; http://www.rowledge.org/tim Fractured Idiom:- QUE SERA SERF - Life is feudal

4 7

← Newer
1
2
3
4
5
6
7
...
15
Older →

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

Vm-dev October 2013