VM Maker: VMMaker.oscog-cb.2405.mcz

 
ClementBera uploaded a new version of VMMaker to project VM Maker:
http://source.squeak.org/VMMaker/VMMaker.oscog-cb.2405.mcz

==================== Summary ====================

Name: VMMaker.oscog-cb.2405
Author: cb
Time: 7 June 2018, 4:16:07.513295 pm
UUID: 5452dde0-de82-486b-bb11-dfd115dcb8be
Ancestors: VMMaker.oscog-eem.2404

- changed the free list representation from linked list to double linked list to unlink efficiently the free chunk in compaction phases.
- Fix some simulation details
- cheated a bit some simulation of VM profiling
- Removed Pig compactor (Incompatible with the new double linked list scheme)
- a few more simulation assertion on freeTreeOverlap

I have not tested yet code generation, testing right now

=============== Diff against VMMaker.oscog-eem.2404 ===============

Item was changed:
  ----- Method: CogClass>>cCoerceSimple:to: (in category 'translation support') -----
  cCoerceSimple: value to: cTypeString
  <doNotGenerate>
  "Type coercion for translation and simulation.
  For simulation answer a suitable surrogate for the struct types"
  ^cTypeString caseOf:
    { [#'unsigned long'] -> [value].
  [#'unsigned int'] -> [value].
  [#'unsigned short'] -> [value].
  [#sqInt] -> [value].
  [#'sqIntptr_t'] -> [value].
  [#'usqIntptr_t'] -> [value].
  [#usqInt] -> [value].
  [#sqLong] -> [value].
  [#usqLong] -> [value].
  [#'AbstractInstruction *'] -> [value].
+ [#'SpurSegmentInfo *'] -> [value].
  [#'BytecodeFixup *'] -> [value].
  [#'CogMethod *'] -> [value].
  [#'char *'] -> [value].
  [#'sqInt *'] -> [value].
  [#'void *'] -> [value].
  [#void] -> [value].
  [#'void (*)()'] -> [value].
  [#'void (*)(void)'] -> [value].
  [#'unsigned long (*)(void)'] -> [value].
  [#'void (*)(unsigned long,unsigned long)'] -> [value].
  [#'usqIntptr_t (*)(void)'] -> [value] }!

Item was changed:
  ----- Method: InterpreterPrimitives>>primitiveControlVMProfiling (in category 'process primitives') -----
  primitiveControlVMProfiling
  "Primitive. Start or stop the VM profiler.  The first argument is a boolean
  to switch profiling on or off.  The second argument is an integer or nil.
  If an integer it determines the maximum number of samples in the VM's
  sample buffer. Answer the current number of samples in the buffer."
  | onOffBar bufferSize numSamples |
  argumentCount ~= 2 ifTrue:
  [^self primitiveFail].
  (onOffBar := self stackValue: 1) = objectMemory trueObject
  ifTrue: [onOffBar := 1]
  ifFalse:
  [onOffBar = objectMemory falseObject
  ifTrue: [onOffBar := 0]
  ifFalse: [^self primitiveFail]].
  (bufferSize := self stackTop) = objectMemory nilObject
  ifTrue: [bufferSize := 0]
  ifFalse:
  [((objectMemory isIntegerObject: bufferSize)
   and: [(bufferSize := objectMemory integerValueOf: bufferSize) > 0]) ifFalse:
  [^self primitiveFail]].
+ numSamples := self cCode: 'ioControlNewProfile(onOffBar,bufferSize)' inSmalltalk: [1667].
- numSamples := self cCode: 'ioControlNewProfile(onOffBar,bufferSize)'.
  self pop: 3 thenPushInteger: numSamples!

Item was changed:
  ----- Method: SpurMemoryManager>>addToFreeList:bytes: (in category 'free space') -----
  addToFreeList: freeChunk bytes: chunkBytes
  "Add freeChunk to the relevant freeList.
  For the benefit of sortedFreeObject:, if freeChunk is large, answer the treeNode it
  is added to, if it is added to the next list of a freeTreeNode, otherwise answer 0."
  | index |
  "coInterpreter transcript ensureCr. coInterpreter print: 'freeing '. self printFreeChunk: freeChunk."
  self assert: (self isFreeObject: freeChunk).
  self assert: chunkBytes = (self bytesInObject: freeChunk).
  index := chunkBytes / self allocationUnit.
  index < self numFreeLists ifTrue:
+ [self setNextFreeChunkOf: freeChunk withValue: (freeLists at: index) chunkBytes: chunkBytes.
+ self storePointer: self freeChunkPrevIndex ofFreeChunk: freeChunk withValue: 0.
- [self storePointer: self freeChunkNextIndex ofFreeChunk: freeChunk withValue: (freeLists at: index).
  freeLists at: index put: freeChunk.
  freeListsMask := freeListsMask bitOr: 1 << index.
  ^0].
 
  ^self addToFreeTree: freeChunk bytes: chunkBytes!

Item was changed:
  ----- Method: SpurMemoryManager>>addToFreeTree:bytes: (in category 'free space') -----
  addToFreeTree: freeChunk bytes: chunkBytes
  "Add freeChunk to the large free chunk tree.
  For the benefit of sortedFreeObject:, answer the treeNode it is added
  to, if it is added to the next list of a freeTreeNode, otherwise answer 0."
  | childBytes parent child |
  self assert: (self isFreeObject: freeChunk).
  self assert: chunkBytes = (self bytesInObject: freeChunk).
  self assert: chunkBytes >= (self numFreeLists * self allocationUnit).
  self
  storePointer: self freeChunkNextIndex ofFreeChunk: freeChunk withValue: 0;
+ storePointer: self freeChunkPrevIndex ofFreeChunk: freeChunk withValue: 0;
  storePointer: self freeChunkParentIndex ofFreeChunk: freeChunk withValue: 0;
  storePointer: self freeChunkSmallerIndex ofFreeChunk: freeChunk withValue: 0;
  storePointer: self freeChunkLargerIndex ofFreeChunk: freeChunk withValue: 0.
  "Large chunk list organized as a tree, each node of which is a list of chunks of the same size.
  Beneath the node are smaller and larger blocks."
  parent := 0.
  child := freeLists at: 0.
  [child ~= 0] whileTrue:
  [childBytes := self bytesInObject: child.
  "check for overlap; could write this as self oop: (self objectAfter: freeChunk) isLessThanOrEqualTo: child...
   but that relies on headers being correct, etc.  So keep it clumsy..."
  self assert: ((self oop: freeChunk + chunkBytes - self baseHeaderSize isLessThanOrEqualTo: child)
  or: [self oop: freeChunk isGreaterThanOrEqualTo: child + childBytes - self baseHeaderSize]).
  childBytes = chunkBytes ifTrue: "size match; add to list at node."
+ [self setNextFreeChunkOf: freeChunk withValue: (self fetchPointer: self freeChunkNextIndex ofFreeChunk: child) sizeIsOne: false.
+ self setNextFreeChunkOf: child withValue: freeChunk sizeIsOne: false.
- [self storePointer: self freeChunkNextIndex
- ofFreeChunk: freeChunk
- withValue: (self fetchPointer: self freeChunkNextIndex ofFreeChunk: child);
- storePointer: self freeChunkNextIndex
- ofFreeChunk: child
- withValue: freeChunk.
  ^child].
  "walk down the tree"
  parent := child.
  child := self fetchPointer: (childBytes > chunkBytes
  ifTrue: [self freeChunkSmallerIndex]
  ifFalse: [self freeChunkLargerIndex])
  ofFreeChunk: child].
  parent = 0 ifTrue:
  [self assert: (freeLists at: 0) = 0.
  freeLists at: 0 put: freeChunk.
  freeListsMask := freeListsMask bitOr: 1.
  ^0].
  self assert: (freeListsMask anyMask: 1).
  "insert in tree"
  self storePointer: self freeChunkParentIndex
  ofFreeChunk: freeChunk
  withValue: parent.
  self storePointer: (childBytes > chunkBytes
  ifTrue: [self freeChunkSmallerIndex]
  ifFalse: [self freeChunkLargerIndex])
  ofFreeChunk: parent
  withValue: freeChunk.
  ^0!

Item was changed:
  ----- Method: SpurMemoryManager>>allocateLargestFreeChunk (in category 'free space') -----
  allocateLargestFreeChunk
  "Answer the largest free chunk in the free lists."
  <inline: false>
  | freeChunk next |
  "would like to use ifNotNil: but the ^next inside the ^blah ifNotNil: confused Slang"
  freeChunk := self findLargestFreeChunk.
  freeChunk ifNil: [^nil].
  "This will be the node, not a list element.  Answer a list element in preference."
  next := self fetchPointer: self freeChunkNextIndex ofFreeChunk: freeChunk.
  next ~= 0 ifTrue:
+ [self assert: (self bytesInObject: freeChunk) >= self numFreeLists. "findLargestFreeChunk searches only the tree"
+ self
+ setNextFreeChunkOf: freeChunk
+ withValue: (self fetchPointer: self freeChunkNextIndex ofFreeChunk: next)
+ sizeIsOne: false.
- [self storePointer: self freeChunkNextIndex
- ofFreeChunk: freeChunk
- withValue: (self fetchPointer: self freeChunkNextIndex ofFreeChunk: next).
  ^next].
  self unlinkSolitaryFreeTreeNode: freeChunk.
  ^freeChunk!

Item was changed:
  ----- Method: SpurMemoryManager>>allocateOldSpaceChunkOfBytes: (in category 'free space') -----
  allocateOldSpaceChunkOfBytes: chunkBytes
  "Answer a chunk of oldSpace from the free lists, if available,
  otherwise answer nil.  Break up a larger chunk if one of the
  exact size does not exist.  N.B.  the chunk is simply a pointer, it
  has no valid header.  The caller *must* fill in the header correctly."
  <var: #chunkBytes type: #usqInt>
  | initialIndex chunk index nodeBytes parent child |
  "for debugging:" "totalFreeOldSpace := self totalFreeListBytes"
  totalFreeOldSpace := totalFreeOldSpace - chunkBytes. "be optimistic (& don't wait for the write)"
  initialIndex := chunkBytes / self allocationUnit.
  (initialIndex < self numFreeLists and: [1 << initialIndex <= freeListsMask]) ifTrue:
  [(freeListsMask anyMask: 1 << initialIndex) ifTrue:
  [(chunk := freeLists at: initialIndex) ~= 0 ifTrue:
  [self assert: chunk = (self startOfObject: chunk).
  self assert: (self isValidFreeObject: chunk).
  ^self unlinkFreeChunk: chunk atIndex: initialIndex].
  freeListsMask := freeListsMask - (1 << initialIndex)].
  "first search for free chunks of a multiple of chunkBytes in size"
  index := initialIndex.
  [(index := index + index) < self numFreeLists
   and: [1 << index <= freeListsMask]] whileTrue:
  [(freeListsMask anyMask: 1 << index) ifTrue:
  [(chunk := freeLists at: index) ~= 0 ifTrue:
  [self assert: chunk = (self startOfObject: chunk).
  self assert: (self isValidFreeObject: chunk).
  self unlinkFreeChunk: chunk atIndex: index.
  self assert: (self bytesInObject: chunk) = (index * self allocationUnit).
  self freeChunkWithBytes: index * self allocationUnit - chunkBytes
  at: (self startOfObject: chunk) + chunkBytes.
  ^chunk].
  freeListsMask := freeListsMask - (1 << index)]].
  "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
+ setNextFreeChunkOf: child
+ withValue: (self fetchPointer: self freeChunkNextIndex ofFreeChunk: chunk)
+ sizeIsOne: false.
- self storePointer: self freeChunkNextIndex
- ofFreeChunk: child
- withValue: (self fetchPointer: self freeChunkNextIndex
- ofFreeChunk: chunk).
  ^self startOfObject: chunk].
  nodeBytes := childBytes.
  parent := child.
  child := 0] "break out of loop to remove interior node"
  ifFalse:
  ["Note that because the minimum free size is 16 bytes (2 * allocationUnit), to
   leave room for the forwarding pointer/next free link, we can only break chunks
   that are at least 16 bytes larger, hence reject chunks < 2 * allocationUnit larger."
  childBytes <= (chunkBytes + self allocationUnit)
  ifTrue: "node too small; walk down the larger size of the tree"
  [child := self fetchPointer: self freeChunkLargerIndex ofFreeChunk: child]
  ifFalse:
  [parent := child. "parent will be smallest node >= chunkBytes + allocationUnit"
  nodeBytes := childBytes.
  child := self fetchPointer: self freeChunkSmallerIndex ofFreeChunk: child]]].
  parent = 0 ifTrue:
  [totalFreeOldSpace := totalFreeOldSpace + chunkBytes. "optimism was unfounded"
  ^nil].
 
  "self printFreeChunk: parent"
  self assert: (nodeBytes = chunkBytes or: [nodeBytes >= (chunkBytes + (2 * self allocationUnit))]).
  self assert: (self bytesInObject: parent) = nodeBytes.
 
  "attempt to remove from list"
  chunk := self fetchPointer: self freeChunkNextIndex ofFreeChunk: parent.
  chunk ~= 0 ifTrue:
  [self assert: (chunkBytes = nodeBytes or: [chunkBytes + self allocationUnit < nodeBytes]).
+ self
+ setNextFreeChunkOf: parent
+ withValue: (self fetchPointer: self freeChunkNextIndex ofFreeChunk: chunk)
+ sizeIsOne: false.
- self storePointer: self freeChunkNextIndex
- ofFreeChunk: parent
- withValue: (self fetchPointer: self freeChunkNextIndex
- ofFreeChunk: chunk).
  chunkBytes ~= nodeBytes ifTrue:
  [self freeChunkWithBytes: nodeBytes - chunkBytes
  at: (self startOfObject: chunk) + chunkBytes].
  ^self startOfObject: chunk].
 
  "no list; remove the interior node"
  chunk := parent.
  self unlinkSolitaryFreeTreeNode: chunk.
 
  "if there's space left over, add the fragment back."
  chunkBytes ~= nodeBytes ifTrue:
  [self freeChunkWithBytes: nodeBytes - chunkBytes
  at: (self startOfObject: chunk) + chunkBytes].
  ^self startOfObject: chunk!

Item was changed:
  ----- Method: SpurMemoryManager>>allocateOldSpaceChunkOfBytes:suchThat: (in category 'free space') -----
  allocateOldSpaceChunkOfBytes: chunkBytes suchThat: acceptanceBlock
  "Answer a chunk of oldSpace from the free lists that satisfies acceptanceBlock,
  if available, otherwise answer nil.  Break up a larger chunk if one of the exact
  size cannot be found.  N.B.  the chunk is simply a pointer, it has no valid header.
  The caller *must* fill in the header correctly."
  <var: #chunkBytes type: #usqInt>
  | initialIndex node next prev index child childBytes acceptedChunk acceptedNode |
  <inline: true> "must inline for acceptanceBlock"
  "for debugging:" "totalFreeOldSpace := self totalFreeListBytes"
  totalFreeOldSpace := totalFreeOldSpace - chunkBytes. "be optimistic (& don't wait for the write)"
  initialIndex := chunkBytes / self allocationUnit.
  (initialIndex < self numFreeLists and: [1 << initialIndex <= freeListsMask]) ifTrue:
  [(freeListsMask anyMask: 1 << initialIndex) ifTrue:
  [(node := freeLists at: initialIndex) = 0
  ifTrue: [freeListsMask := freeListsMask - (1 << initialIndex)]
  ifFalse:
  [prev := 0.
  [node ~= 0] whileTrue:
  [self assert: node = (self startOfObject: node).
  self assert: (self isValidFreeObject: node).
  next := self fetchPointer: self freeChunkNextIndex ofFreeChunk: node.
  (acceptanceBlock value: node) ifTrue:
  [prev = 0
  ifTrue: [freeLists at: initialIndex put: next]
+ ifFalse: [self setNextFreeChunkOf: prev withValue: next chunkBytes: chunkBytes].
- ifFalse: [self storePointer: self freeChunkNextIndex ofFreeChunk: prev withValue: next].
  ^node].
  prev := node.
  node := next]]].
  "first search for free chunks of a multiple of chunkBytes in size"
  index := initialIndex.
  [(index := index + initialIndex) < self numFreeLists
   and: [1 << index <= freeListsMask]] whileTrue:
  [(freeListsMask anyMask: 1 << index) ifTrue:
  [(node := freeLists at: index) = 0
  ifTrue: [freeListsMask := freeListsMask - (1 << index)]
  ifFalse:
  [prev := 0.
  [node ~= 0] whileTrue:
  [self assert: node = (self startOfObject: node).
  self assert: (self isValidFreeObject: node).
  next := self fetchPointer: self freeChunkNextIndex ofFreeChunk: node.
  (acceptanceBlock value: node) ifTrue:
  [prev = 0
  ifTrue: [freeLists at: index put: next]
+ ifFalse: [self setNextFreeChunkOf: prev withValue: next chunkBytes: chunkBytes].
- ifFalse: [self storePointer: self freeChunkNextIndex ofFreeChunk: prev withValue: next].
  self freeChunkWithBytes: index * self allocationUnit - chunkBytes
  at: (self startOfObject: node) + chunkBytes.
  ^node].
  prev := node.
  node := next]]]].
  "now get desperate and use the first that'll fit.
   Note that because the minimum free size is 16 bytes (2 * allocationUnit), to
   leave room for the forwarding pointer/next free link, we can only break chunks
   that are at least 16 bytes larger, hence start at initialIndex + 2."
  index := initialIndex + 1.
  [(index := index + 1) < self numFreeLists
   and: [1 << index <= freeListsMask]] whileTrue:
  [(freeListsMask anyMask: 1 << index) ifTrue:
  [(node := freeLists at: index) = 0
  ifTrue: [freeListsMask := freeListsMask - (1 << index)]
  ifFalse:
  [prev := 0.
  [node ~= 0] whileTrue:
  [self assert: node = (self startOfObject: node).
  self assert: (self isValidFreeObject: node).
  next := self fetchPointer: self freeChunkNextIndex ofFreeChunk: node.
  (acceptanceBlock value: node) ifTrue:
  [prev = 0
  ifTrue: [freeLists at: index put: next]
+ ifFalse: [self setNextFreeChunkOf: prev withValue: next chunkBytes: chunkBytes].
- ifFalse: [self storePointer: self freeChunkNextIndex ofFreeChunk: prev withValue: next].
  self freeChunkWithBytes: index * self allocationUnit - chunkBytes
  at: (self startOfObject: node) + chunkBytes.
  ^node].
  prev := node.
  node := next]]]]].
 
  "Large chunk, or no space on small free lists.  Search the large chunk list.
  Large chunk list organized as a tree, each node of which is a list of chunks
  of the same size. Beneath the node are smaller and larger blocks.
  When the search ends parent should hold the smallest chunk at least as
  large as chunkBytes, or 0 if none.  acceptedChunk and acceptedNode save
  us from having to back-up when the acceptanceBlock filters-out all nodes
  of the right size, but there are nodes of the wrong size it does accept."
  child := freeLists at: 0.
  node := acceptedChunk := acceptedNode := 0.
  [child ~= 0] whileTrue:
  [self assert: (self isValidFreeObject: child).
  childBytes := self bytesInObject: child.
  childBytes = chunkBytes ifTrue: "size match; try to remove from list at node."
  [node := child.
  [prev := node.
   node := self fetchPointer: self freeChunkNextIndex ofFreeChunk: node.
   node ~= 0] whileTrue:
  [(acceptanceBlock value: node) ifTrue:
  [self assert: (self isValidFreeObject: node).
+ self setNextFreeChunkOf: prev withValue: (self fetchPointer: self freeChunkNextIndex ofFreeChunk: node) sizeIsOne: false.
- self storePointer: self freeChunkNextIndex
- ofFreeChunk: prev
- withValue: (self fetchPointer: self freeChunkNextIndex ofFreeChunk: node).
  ^self startOfObject: node]].
  (acceptanceBlock value: child) ifTrue:
  [next := self fetchPointer: self freeChunkNextIndex ofFreeChunk: child.
  next = 0
  ifTrue: "no list; remove the interior node"
  [self unlinkSolitaryFreeTreeNode: child]
  ifFalse: "list; replace node with it"
  [self inFreeTreeReplace: child with: next].
  ^self startOfObject: child]].
  child ~= 0 ifTrue:
  ["Note that because the minimum free size is 16 bytes (2 * allocationUnit), to
   leave room for the forwarding pointer/next free link, we can only break chunks
   that are at least 16 bytes larger, hence reject chunks < 2 * allocationUnit larger."
  childBytes <= (chunkBytes + self allocationUnit)
  ifTrue: "node too small; walk down the larger size of the tree"
  [child := self fetchPointer: self freeChunkLargerIndex ofFreeChunk: child]
  ifFalse:
  [self flag: 'we can do better here; preferentially choosing the lowest node. That would be a form of best-fit since we are trying to compact down'.
  node := child.
  child := self fetchPointer: self freeChunkSmallerIndex ofFreeChunk: node.
  acceptedNode = 0 ifTrue:
  [acceptedChunk := node.
  "first search the list."
  [acceptedChunk := self fetchPointer: self freeChunkNextIndex
  ofFreeChunk: acceptedChunk.
   (acceptedChunk ~= 0 and: [acceptanceBlock value: acceptedChunk]) ifTrue:
  [acceptedNode := node].
   acceptedChunk ~= 0 and: [acceptedNode = 0]] whileTrue.
  "nothing on the list; will the node do?  This prefers
   acceptable nodes higher up the tree over acceptable
   list elements further down, but we haven't got all day..."
  (acceptedNode = 0
   and: [acceptanceBlock value: node]) ifTrue:
  [acceptedNode := node.
  child := 0 "break out of loop now we have an acceptedNode"]]]]].
 
  acceptedNode ~= 0 ifTrue:
  [acceptedChunk ~= 0 ifTrue:
  [self assert: (self bytesInObject: acceptedChunk) >= (chunkBytes + self allocationUnit).
  [next := self fetchPointer: self freeChunkNextIndex ofFreeChunk: acceptedNode.
   next ~= acceptedChunk] whileTrue:
  [acceptedNode := next].
+ self
+ setNextFreeChunkOf: acceptedNode
+ withValue: (self fetchPointer: self freeChunkNextIndex ofFreeChunk: acceptedChunk)
+ sizeIsOne: false.
- self storePointer: self freeChunkNextIndex
- ofFreeChunk: acceptedNode
- withValue: (self fetchPointer: self freeChunkNextIndex ofFreeChunk: acceptedChunk).
  self freeChunkWithBytes: (self bytesInObject: acceptedChunk) - chunkBytes
  at: (self startOfObject: acceptedChunk) + chunkBytes.
  ^self startOfObject: acceptedChunk].
  next := self fetchPointer: self freeChunkNextIndex ofFreeChunk: acceptedNode.
  next = 0
  ifTrue: "no list; remove the interior node"
  [self unlinkSolitaryFreeTreeNode: acceptedNode]
  ifFalse: "list; replace node with it"
  [self inFreeTreeReplace: acceptedNode with: next].
  self assert: (self bytesInObject: acceptedNode) >= (chunkBytes + self allocationUnit).
  self freeChunkWithBytes: (self bytesInObject: acceptedNode) - chunkBytes
  at: (self startOfObject: acceptedNode) + chunkBytes.
  ^self startOfObject: acceptedNode].
 
  totalFreeOldSpace := totalFreeOldSpace + chunkBytes. "optimism was unfounded"
  ^nil!

Item was changed:
  ----- Method: SpurMemoryManager>>allocateOldSpaceChunkOfExactlyBytes: (in category 'free space') -----
  allocateOldSpaceChunkOfExactlyBytes: chunkBytes
  "Answer a chunk of oldSpace from the free lists, if one of this size
  is available, otherwise answer nil.  N.B.  the chunk is simply a pointer,
  it has no valid header.  The caller *must* fill in the header correctly."
  <var: #chunkBytes type: #usqInt>
  | index node child |
  "for debugging:" "totalFreeOldSpace := self totalFreeListBytes"
 
  index := chunkBytes / self allocationUnit.
  index < self numFreeLists ifTrue:
  [(freeListsMask anyMask: 1 << index) ifTrue:
  [(node := freeLists at: index) ~= 0 ifTrue:
  [self assert: node = (self startOfObject: node).
  self assert: (self isValidFreeObject: node).
  totalFreeOldSpace := totalFreeOldSpace - chunkBytes.
  ^self unlinkFreeChunk: node atIndex: index].
  freeListsMask := freeListsMask - (1 << index)].
  ^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."
  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
+ setNextFreeChunkOf: child
+ withValue: (self fetchPointer: self freeChunkNextIndex ofFreeChunk: node)
+ sizeIsOne: false.
- self storePointer: self freeChunkNextIndex
- ofFreeChunk: child
- withValue: (self fetchPointer: self freeChunkNextIndex
- ofFreeChunk: node).
  totalFreeOldSpace := totalFreeOldSpace - chunkBytes.
  ^self startOfObject: node].
  "nothing acceptable on node's list; answer the node."
  self unlinkSolitaryFreeTreeNode: child.
  totalFreeOldSpace := totalFreeOldSpace - chunkBytes.
  ^self startOfObject: child]
  ifFalse:
  [child := self fetchPointer: (childBytes < chunkBytes
  ifTrue: [self freeChunkLargerIndex]
  ifFalse: [self freeChunkSmallerIndex])
  ofFreeChunk: child]].
  ^nil!

Item was changed:
  ----- Method: SpurMemoryManager>>allocateOldSpaceChunkOfExactlyBytes:suchThat: (in category 'free space') -----
  allocateOldSpaceChunkOfExactlyBytes: chunkBytes suchThat: acceptanceBlock
  "Answer a chunk of oldSpace from the free lists that satisfies acceptanceBlock,
  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."
  <var: #chunkBytes type: #usqInt>
  | index node next prev child childBytes |
  <inline: true> "must inline for acceptanceBlock"
  "for debugging:" "totalFreeOldSpace := self totalFreeListBytes"
 
  index := chunkBytes / self allocationUnit.
  index < self numFreeLists ifTrue:
  [(freeListsMask anyMask: 1 << index) ifTrue:
  [(node := freeLists at: index) = 0
  ifTrue: [freeListsMask := freeListsMask - (1 << index)]
  ifFalse:
  [prev := 0.
  [node ~= 0] whileTrue:
  [self assert: node = (self startOfObject: node).
  self assert: (self isValidFreeObject: node).
  next := self fetchPointer: self freeChunkNextIndex ofFreeChunk: node.
  (acceptanceBlock value: node) ifTrue:
  [prev = 0
  ifTrue: [freeLists at: index put: next]
+ ifFalse: [self setNextFreeChunkOf: prev withValue: next chunkBytes: chunkBytes].
- ifFalse: [self storePointer: self freeChunkNextIndex ofFreeChunk: prev withValue: next].
  totalFreeOldSpace := totalFreeOldSpace - chunkBytes.
  ^node].
  prev := node.
  node := next]]].
  ^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:
  [self "Sorry stepping over isValidFreeObject all the time was killing me"
  cCode: [self assert: (self isValidFreeObject: child)]
  inSmalltalk: [self assertValidFreeObject: child].
  childBytes := self bytesInObject: child.
  childBytes = chunkBytes
  ifTrue: "size match; try to remove from list at node first."
  [node := child.
  [prev := node.
   node := self fetchPointer: self freeChunkNextIndex ofFreeChunk: node.
   node ~= 0] whileTrue:
  [(acceptanceBlock value: node) ifTrue:
  [self assert: (self isValidFreeObject: node).
+ self
+ setNextFreeChunkOf: prev
+ withValue: (self fetchPointer: self freeChunkNextIndex ofFreeChunk: node)
+ sizeIsOne: false.
- self storePointer: self freeChunkNextIndex
- ofFreeChunk: prev
- withValue: (self fetchPointer: self freeChunkNextIndex ofFreeChunk: node).
  totalFreeOldSpace := totalFreeOldSpace - chunkBytes.
  ^self startOfObject: node]].
  (acceptanceBlock value: child) ifFalse:
  [^nil]. "node was right size but unaceptable."
  next := self fetchPointer: self freeChunkNextIndex ofFreeChunk: child.
  next = 0
  ifTrue: "no list; remove the interior node"
  [self unlinkSolitaryFreeTreeNode: child]
  ifFalse: "list; replace node with it"
  [self inFreeTreeReplace: child with: next].
  totalFreeOldSpace := totalFreeOldSpace - chunkBytes.
  ^self startOfObject: child]
  ifFalse: "no size match; walk down the tree"
  [child := self fetchPointer: (childBytes < chunkBytes
  ifTrue: [self freeChunkLargerIndex]
  ifFalse: [self freeChunkSmallerIndex])
  ofFreeChunk: child]].
  ^nil!

Item was changed:
  ----- Method: SpurMemoryManager>>assertValidFreeObject: (in category 'free space') -----
  assertValidFreeObject: objOop
  <doNotGenerate> "If you want to generate this you want to use 'self assert: (self isValidFreeObject: objOop)' instead not to generate code in assertion-free VMs"
  | chunk |
  "duplicated assertions from isValidFreeObject: because I need to know what is wrong not only that it is not valid (I got bored of stepping inside isValidFreeObject:...)"
  self assert: (self oop: (self addressAfter: objOop) isLessThanOrEqualTo: endOfMemory).
  chunk := self fetchPointer: self freeChunkNextIndex ofFreeChunk: objOop.
  self assert: (chunk = 0 or: [self isFreeOop: chunk]).
+ (self bytesInObject: objOop) / self wordSize = 1 ifFalse:
+ ["double linkedlist assertions"
+ chunk := self fetchPointer: self freeChunkNextIndex ofFreeChunk: objOop.
+ chunk = 0 ifFalse:
+ [self assert: (self isFreeOop: chunk).
+ self assert: objOop = (self fetchPointer: self freeChunkPrevIndex ofFreeChunk: chunk)].
+ chunk := self fetchPointer: self freeChunkPrevIndex ofFreeChunk: objOop.
+ chunk = 0 ifFalse:
+ [self assert: (self isFreeOop: chunk).
+ self assert: objOop = (self fetchPointer: self freeChunkNextIndex ofFreeChunk: chunk)].].
+ (self isLargeFreeObject: objOop) ifTrue:
+ ["Tree assertions"
- (self isLargeFreeObject: objOop) ifTrue: [
- "Tree assertions"
  chunk := self fetchPointer: self freeChunkParentIndex ofFreeChunk: objOop.
  self assert: (chunk = 0 or: [(self isFreeOop: chunk) and: [self isLargeFreeObject: chunk]]).
  chunk := self fetchPointer: self freeChunkSmallerIndex ofFreeChunk: objOop.
  self assert: (chunk = 0 or: [(self isFreeOop: chunk) and: [self isLargeFreeObject: chunk]]).
  chunk := self fetchPointer: self freeChunkLargerIndex ofFreeChunk: objOop.
  self assert: (chunk = 0 or: [(self isFreeOop: chunk) and: [self isLargeFreeObject: chunk]]). ]!

Item was changed:
  ----- Method: SpurMemoryManager>>checkHeapFreeSpaceIntegrity (in category 'debug support') -----
  checkHeapFreeSpaceIntegrity
  "Perform an integrity/leak check using the heapMap.  Assume clearLeakMapAndMapAccessibleFreeSpace
  has set a bit at each free chunk's header.  Scan all objects in the heap checking that no pointer points
  to a free chunk and that all free chunks that refer to others refer to marked chunks.  Answer if all checks pass."
  | ok total |
  <inline: false>
  <var: 'total' type: #usqInt>
  ok := true.
  total := 0.
  0 to: self numFreeLists - 1 do:
  [:i|
  (freeLists at: i) ~= 0 ifTrue:
  [(heapMap heapMapAtWord: (self pointerForOop: (freeLists at: i))) = 0 ifTrue:
  [coInterpreter print: 'leak in free list '; printNum: i; print: ' to non-free '; printHex: (freeLists at: i); cr.
  self eek.
  ok := false]]].
 
  "Excuse the duplication but performance is at a premium and we avoid
  some tests by splitting the newSpace and oldSpace enumerations."
  self allNewSpaceEntitiesDo:
  [:obj| | fieldOop |
  (self isFreeObject: obj)
  ifTrue:
  [coInterpreter print: 'young object '; printHex: obj; print: ' is free'; cr.
  self eek.
  ok := false]
  ifFalse:
  [0 to: (self numPointerSlotsOf: obj) - 1 do:
  [:fi|
  fieldOop := self fetchPointer: fi ofObject: obj.
  (self isNonImmediate: fieldOop) ifTrue:
  [(heapMap heapMapAtWord: (self pointerForOop: fieldOop)) ~= 0 ifTrue:
  [coInterpreter print: 'object leak in '; printHex: obj; print: ' @ '; printNum: fi; print: ' = '; printHex: fieldOop; print: ' is free'; cr.
  self eek.
  ok := false]]]]].
  self allOldSpaceEntitiesDo:
  [:obj| | fieldOop |
  (self isFreeObject: obj)
  ifTrue:
  [(heapMap heapMapAtWord: (self pointerForOop: obj)) = 0 ifTrue:
  [coInterpreter print: 'leak in free chunk '; printHex: obj; print: ' is unmapped?!! '; cr.
  self eek.
  ok := false].
  fieldOop := self fetchPointer: self freeChunkNextIndex ofFreeChunk: obj.
  (fieldOop ~= 0
  and: [(heapMap heapMapAtWord: (self pointerForOop: fieldOop)) = 0]) ifTrue:
  [coInterpreter print: 'leak in free chunk '; printHex: obj; print: ' @ 0 = '; printHex: fieldOop; print: ' is unmapped'; cr.
  self eek.
  ok := false].
+ (self bytesInObject: obj) / self wordSize = 1 ifFalse:
+ [fieldOop := self fetchPointer: self freeChunkPrevIndex ofFreeChunk: obj.
+ (fieldOop ~= 0
+ and: [(heapMap heapMapAtWord: (self pointerForOop: fieldOop)) = 0]) ifTrue:
+ [coInterpreter print: 'leak in free chunk '; printHex: obj; print: ' @ 0 = '; printHex: fieldOop; print: ' is unmapped'; cr.
+ self eek.
+ ok := false]].
  (self isLargeFreeObject: obj) ifTrue:
  [self freeChunkParentIndex to: self freeChunkLargerIndex do:
  [:fi|
  fieldOop := self fetchPointer: fi ofFreeChunk: obj.
  (fieldOop ~= 0
  and: [(heapMap heapMapAtWord: (self pointerForOop: fieldOop)) = 0]) ifTrue:
  [coInterpreter print: 'leak in free chunk '; printHex: obj; print: ' @ '; printNum: fi; print: ' = '; printHex: fieldOop; print: ' is unmapped'; cr.
  self eek.
  ok := false]]].
  total := total + (self bytesInObject: obj)]
  ifFalse:
  [0 to: (self numPointerSlotsOf: obj) - 1 do:
  [:fi|
  (self isForwarded: obj)
  ifTrue:
  [self assert: fi = 0. "I'm now trying to use forwarders in GC algorithms..."
  fieldOop := self fetchPointer: fi ofMaybeForwardedObject: obj]
  ifFalse: "We keep #fetchPointer:ofObject: API here for assertions"
  [fieldOop := self fetchPointer: fi ofObject: obj].
  (self isNonImmediate: fieldOop) ifTrue:
  [(heapMap heapMapAtWord: (self pointerForOop: fieldOop)) ~= 0 ifTrue:
  [coInterpreter print: 'object leak in '; printHex: obj; print: ' @ '; printNum: fi; print: ' = '; printHex: fieldOop; print: ' is free'; cr.
  self eek.
  ok := false]]]]].
  total ~= totalFreeOldSpace ifTrue:
  [coInterpreter print: 'incorrect totalFreeOldSpace; expected '; printNum: totalFreeOldSpace; print: ' found '; printNum: total; cr.
  self eek.
  ok := false].
  ^ok!

Item was changed:
  ----- Method: SpurMemoryManager>>checkHeapIntegrity:classIndicesShouldBeValid: (in category 'debug support') -----
  checkHeapIntegrity: excludeUnmarkedObjs classIndicesShouldBeValid: classIndicesShouldBeValid
  "Perform an integrity/leak check using the heapMap.  Assume clearLeakMapAndMapAccessibleObjects
  has set a bit at each (non-free) object's header.  Scan all objects in the heap checking that every
  pointer points to a header.  Scan the rememberedSet, remapBuffer and extraRootTable checking
  that every entry is a pointer to a header. Check that the number of roots is correct and that all
  rememberedSet entries have their isRemembered: flag set.  Answer if all checks pass."
  | ok numRememberedObjectsInHeap |
  <inline: false>
  self cCode: []
  inSmalltalk:
  ["Almost all of the time spent here used to go into the asserts in fetchPointer:ofObject: in the
   simulator class overrides. Since we know here the indices used are valid we temporarily
   remove them to claw back that performance."
  (self class whichClassIncludesSelector: #fetchPointer:ofObject:) ~= SpurMemoryManager ifTrue:
  [^self withSimulatorFetchPointerMovedAsideDo:
  [self checkHeapIntegrity: excludeUnmarkedObjs
  classIndicesShouldBeValid: classIndicesShouldBeValid]]].
  ok := true.
  numRememberedObjectsInHeap := 0.
  0 to: self numFreeLists - 1 do:
  [:i|
  (freeLists at: i) ~= 0 ifTrue:
  [(heapMap heapMapAtWord: (self pointerForOop: (freeLists at: i))) ~= 0 ifTrue:
  [coInterpreter print: 'leak in free list '; printNum: i; print: ' to non-free '; printHex: (freeLists at: i); cr.
  self eek.
  ok := false]]].
 
  "Excuse the duplication but performance is at a premium and we avoid
  some tests by splitting the newSpace and oldSpace enumerations."
  self allNewSpaceEntitiesDo:
  [:obj| | fieldOop classIndex classOop |
  (self isFreeObject: obj)
  ifTrue:
  [coInterpreter print: 'young object '; printHex: obj; print: ' is free'; cr.
  self eek.
  ok := false]
  ifFalse:
  [((self isMarked: obj) not and: [excludeUnmarkedObjs]) ifFalse:
  [(self isRemembered: obj) ifTrue:
  [coInterpreter print: 'young object '; printHex: obj; print: ' is remembered'; cr.
  self eek.
  ok := false]].
  (self isForwarded: obj)
  ifTrue:
  [fieldOop := self fetchPointer: 0 ofMaybeForwardedObject: obj.
  (heapMap heapMapAtWord: (self pointerForOop: fieldOop)) = 0 ifTrue:
  [coInterpreter print: 'object leak in forwarder '; printHex: obj; print: ' to unmapped '; printHex: fieldOop; cr.
  self eek.
  ok := false]]
  ifFalse:
  [classOop := self classOrNilAtIndex: (classIndex := self classIndexOf: obj).
  (classIndicesShouldBeValid
   and: [classOop = nilObj
   and: [(self isHiddenObj: obj) not]]) ifTrue:
  [coInterpreter print: 'object leak in '; printHex: obj; print: ' invalid class index '; printHex: classIndex; print: ' -> '; print: (classOop ifNil: ['nil'] ifNotNil: ['nilObj']); cr.
  self eek.
  ok := false].
  0 to: (self numPointerSlotsOf: obj) - 1 do:
  [:fi|
  fieldOop := self fetchPointer: fi ofObject: obj.
  (self isNonImmediate: fieldOop) ifTrue:
  [(heapMap heapMapAtWord: (self pointerForOop: fieldOop)) = 0 ifTrue:
  [coInterpreter print: 'object leak in '; printHex: obj; print: ' @ '; printNum: fi; print: ' = '; printHex: fieldOop; cr.
  self eek.
  ok := false]]]]]].
  self allOldSpaceEntitiesDo:
  [:obj| | containsYoung fieldOop classIndex classOop |
  (self isFreeObject: obj)
  ifTrue:
  [(heapMap heapMapAtWord: (self pointerForOop: obj)) ~= 0 ifTrue:
  [coInterpreter print: 'leak in free chunk '; printHex: obj; print: ' is mapped?!! '; cr.
  self eek.
  ok := false].
  fieldOop := self fetchPointer: self freeChunkNextIndex ofFreeChunk: obj.
  (fieldOop ~= 0
  and: [(heapMap heapMapAtWord: (self pointerForOop: obj)) ~= 0]) ifTrue:
  [coInterpreter print: 'leak in free chunk '; printHex: obj; print: ' @ 0 = '; printHex: fieldOop; print: ' is mapped'; cr.
  self eek.
  ok := false].
+ (self bytesInObject: obj) / self wordSize = 1 ifFalse:
+ [fieldOop := self fetchPointer: self freeChunkPrevIndex ofFreeChunk: obj.
+ (fieldOop ~= 0
+ and: [(heapMap heapMapAtWord: (self pointerForOop: fieldOop)) = 0]) ifTrue:
+ [coInterpreter print: 'leak in free chunk '; printHex: obj; print: ' @ 0 = '; printHex: fieldOop; print: ' is unmapped'; cr.
+ self eek.
+ ok := false]].
  (self isLargeFreeObject: obj) ifTrue:
  [self freeChunkParentIndex to: self freeChunkLargerIndex do:
  [:fi|
  fieldOop := self fetchPointer: fi ofFreeChunk: obj.
  (fieldOop ~= 0
  and: [(heapMap heapMapAtWord: (self pointerForOop: obj)) ~= 0]) ifTrue:
  [coInterpreter print: 'leak in free chunk '; printHex: obj; print: ' @ '; printNum: fi; print: ' = '; printHex: fieldOop; print: ' is mapped'; cr.
  self eek.
  ok := false].]]]
  ifFalse:
  [(excludeUnmarkedObjs and: [(self isMarked: obj)not]) ifTrue: [] ifFalse: [
  containsYoung := false.
  (self isRemembered: obj) ifTrue:
  [numRememberedObjectsInHeap := numRememberedObjectsInHeap + 1.
  (scavenger isInRememberedSet: obj) ifFalse:
  [coInterpreter print: 'remembered object '; printHex: obj; print: ' is not in remembered table'; cr.
  self eek.
  ok := false]].
  (self isForwarded: obj)
  ifTrue:
  [fieldOop := self fetchPointer: 0 ofMaybeForwardedObject: obj.
  (heapMap heapMapAtWord: (self pointerForOop: fieldOop)) = 0 ifTrue:
  [coInterpreter print: 'object leak in forwarder '; printHex: obj; print: ' to unmapped '; printHex: fieldOop; cr.
  self eek.
  ok := false].
  (self isReallyYoung: fieldOop) ifTrue:
  [containsYoung := true]]
  ifFalse:
  [classOop := self classOrNilAtIndex: (classIndex := self classIndexOf: obj).
  (classIndicesShouldBeValid
   and: [classOop = nilObj
   and: [classIndex > self lastClassIndexPun]]) ifTrue:
  [coInterpreter print: 'object leak in '; printHex: obj; print: ' invalid class index '; printHex: classIndex; print: ' -> '; print: (classOop ifNil: ['nil'] ifNotNil: ['nilObj']); cr.
  self eek.
  ok := false].
  0 to: (self numPointerSlotsOf: obj) - 1 do:
  [:fi|
  fieldOop := self fetchPointer: fi ofObject: obj.
  (self isNonImmediate: fieldOop) ifTrue:
  [(self heapMapAtWord: (self pointerForOop: fieldOop)) = 0 ifTrue:
  [coInterpreter print: 'object leak in '; printHex: obj; print: ' @ '; printNum: fi; print: ' = '; printHex: fieldOop; cr.
  self eek.
  ok := false].
  "don't be misled by CogMethods; they appear to be young, but they're not"
  (self isReallyYoung: fieldOop) ifTrue:
  [containsYoung := true]]]].
  containsYoung ifTrue:
  [(self isRemembered: obj) ifFalse:
  [coInterpreter print: 'unremembered object '; printHex: obj; print: ' contains young oop(s)'; cr.
  self eek.
  ok := false]]]]].
  numRememberedObjectsInHeap ~= scavenger rememberedSetSize ifTrue:
  [coInterpreter
  print: 'root count mismatch. #heap roots ';
  printNum: numRememberedObjectsInHeap;
  print: '; #roots ';
  printNum: scavenger rememberedSetSize;
  cr.
  self eek.
  "But the system copes with overflow..."
  self flag: 'no support for remembered set overflow yet'.
  "ok := rootTableOverflowed and: [needGCFlag]"].
  scavenger rememberedSetWithIndexDo:
  [:obj :i|
  (obj bitAnd: self wordSize - 1) ~= 0
  ifTrue:
  [coInterpreter print: 'misaligned oop in remembered set @ '; printNum: i; print: ' = '; printHex: obj; cr.
  self eek.
  ok := false]
  ifFalse:
  [(heapMap heapMapAtWord: (self pointerForOop: obj)) = 0
  ifTrue:
  [coInterpreter print: 'object leak in remembered set @ '; printNum: i; print: ' = '; printHex: obj; cr.
  self eek.
  ok := false]
  ifFalse:
  [(self isYoung: obj) ifTrue:
  [coInterpreter print: 'non-root in remembered set @ '; printNum: i; print: ' = '; printHex: obj; cr.
  self eek.
  ok := false]]]].
  self objStack: mournQueue do:
  [:i :page| | obj |
  obj := self fetchPointer: i ofObject: page.
  (obj bitAnd: self wordSize - 1) ~= 0
  ifTrue:
  [coInterpreter print: 'misaligned oop in mournQueue @ '; printNum: i; print: ' in '; printHex: page; print: ' = '; printHex: obj; cr.
  self eek.
  ok := false]
  ifFalse:
  [(excludeUnmarkedObjs and: [(self isMarked: obj) not]) ifFalse:
  [(heapMap heapMapAtWord: (self pointerForOop: obj)) = 0 ifTrue:
  [coInterpreter print: 'object leak in mournQueue @ '; printNum: i; print: ' in '; printHex: page; print: ' = '; printHex: obj; cr.
  self eek.
  ok := false]]]].
  1 to: remapBufferCount do:
  [:ri| | obj |
  obj := remapBuffer at: ri.
  (obj bitAnd: self wordSize - 1) ~= 0
  ifTrue:
  [coInterpreter print: 'misaligned remapRoot @ '; printNum: ri; print: ' = '; printHex: obj; cr.
  self eek.
  ok := false]
  ifFalse:
  [(heapMap heapMapAtWord: (self pointerForOop: obj)) = 0 ifTrue:
  [coInterpreter print: 'object leak in remapRoots @ '; printNum: ri; print: ' = '; printHex: obj; cr.
  self eek.
  ok := false]]].
  1 to: extraRootCount do:
  [:ri| | obj |
  obj := (extraRoots at: ri) at: 0.
  (obj bitAnd: self wordSize - 1) ~= 0
  ifTrue:
  [coInterpreter print: 'misaligned extraRoot @ '; printNum: ri; print: ' => '; printHex: obj; cr.
  self eek.
  ok := false]
  ifFalse:
  [(heapMap heapMapAtWord: (self pointerForOop: obj)) = 0 ifTrue:
  [coInterpreter print: 'object leak in extraRoots @ '; printNum: ri; print: ' => '; printHex: obj; cr.
  self eek.
  ok := false]]].
  ^ok!

Item was changed:
  ----- Method: SpurMemoryManager>>detachFreeObject: (in category 'free space') -----
  detachFreeObject: freeChunk
  "This is a rare operation, so its efficiency isn't critical.
  Having a valid prev link for tree nodes would help."
+ <inline: true>
+ | chunkBytes |
- <inline: false>
- | chunkBytes result |
  chunkBytes := self bytesInObject: freeChunk.
+ totalFreeOldSpace := totalFreeOldSpace - chunkBytes.
+ self unlinkFreeChunk: freeChunk chunkBytes: chunkBytes!
- result := self allocateOldSpaceChunkOfExactlyBytes: chunkBytes suchThat: [:f| f = freeChunk].
- self assert: result = (self startOfObject: freeChunk).
- !

Item was removed:
- ----- Method: SpurMemoryManager>>freeChunkNextAddressIndex (in category 'free space') -----
- freeChunkNextAddressIndex
- "for sorting free chunks in memory order"
- ^1!

Item was added:
+ ----- Method: SpurMemoryManager>>freeChunkPrevIndex (in category 'free space') -----
+ freeChunkPrevIndex
+ "For linking objecs on each free list, doubly-linking the free objects.
+ Free chunks of size 1 do not have a prev index."
+ ^1!

Item was added:
+ ----- Method: SpurMemoryManager>>freeTreeOverlapCheck (in category 'free space') -----
+ freeTreeOverlapCheck
+ <doNotGenerate>
+ "Assumes no 2 consecutive free chunks"
+ self allObjectsInFreeTreeDo: [:freeNode1|
+ self allObjectsInFreeTreeDo: [:freeNode2|
+ freeNode1 == freeNode2
+ ifFalse:
+ [|start1 start2 end1 end2|
+ start1 := self startOfObject: freeNode1.
+ start2 := self startOfObject: freeNode2.
+ end1 := start1 + (self bytesInObject: freeNode1).
+ end2 := start2 + (self bytesInObject: freeNode2).
+ "
+ Transcript
+ show: '['; show: start1; show: ';';
+ show: end1; show: '];'; cr; show: '['; show: start2;
+ show: ';'; show: end2; show: ']'; cr.
+ "
+ self assert: (start2 > end1 or: [end2 < start1]).
+ self assert: (start1 > end2 or: [start1 < start2])]]].!

Item was changed:
  ----- Method: SpurMemoryManager>>inFreeTreeReplace:with: (in category 'free space') -----
  inFreeTreeReplace: treeNode with: newNode
  "Part of reorderReversedTreeList:.  Switch treeNode with newNode in
  the tree, but do nothing to the list linked through freeChunkNextIndex."
  | relative |
+ self storePointer: self freeChunkPrevIndex ofFreeChunk: newNode withValue: 0.
  "copy parent, smaller, larger"
  self freeChunkParentIndex to: self freeChunkLargerIndex do:
  [:i|
  relative := self fetchPointer: i ofFreeChunk: treeNode.
  i = self freeChunkParentIndex
  ifTrue:
  [relative = 0
  ifTrue: "update root to point to newNode"
  [self assert: (freeLists at: 0) = treeNode.
  freeLists at: 0 put: newNode]
  ifFalse: "replace link from parent to treeNode with link to newNode."
  [self storePointer: (treeNode = (self fetchPointer: self freeChunkSmallerIndex ofFreeChunk: relative)
  ifTrue: [self freeChunkSmallerIndex]
  ifFalse: [self freeChunkLargerIndex])
  ofFreeChunk: relative
  withValue: newNode]]
  ifFalse:
  [relative ~= 0 ifTrue:
  [self assert: (self fetchPointer: self freeChunkParentIndex ofFreeChunk: relative) = treeNode.
  self storePointer: self freeChunkParentIndex ofFreeChunk: relative withValue: newNode]].
  self storePointer: i ofFreeChunk: newNode withValue: relative.
  self storePointer: i ofFreeChunk: treeNode withValue: 0]!

Item was changed:
  ----- Method: SpurMemoryManager>>initializeObjectMemory: (in category 'initialization') -----
  initializeObjectMemory: bytesToShift
  "Initialize object memory variables at startup time. Assume endOfMemory at al are
  initialised by the image-reading code via setHeapBase:memoryLimit:endOfMemory:.
  endOfMemory is assumed to point to the end of the last object in the image.
  Assume: image reader also initializes the following variables:
  specialObjectsOop
  lastHash"
  <inline: false>
  | freeListObj |
  "Catch mis-initializations leading to bad translations to C"
  self assert: self baseHeaderSize = self baseHeaderSize.
  self assert: (self maxSlotsForAlloc * self wordSize) asInteger > 0.
  self bootstrapping ifFalse:
  [self
  initSegmentBridgeWithBytes: self bridgeSize
  at: endOfMemory - self bridgeSize].
  segmentManager adjustSegmentSwizzlesBy: bytesToShift.
  "image may be at a different address; adjust oops for new location"
  self adjustAllOopsBy: bytesToShift.
  specialObjectsOop := segmentManager swizzleObj: specialObjectsOop.
 
  "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 = oldSpaceStart.
  self assert: falseObj = (self oldSpaceObjectAfter: nilObj).
  self assert: trueObj = (self oldSpaceObjectAfter: falseObj).
  freeListObj := self oldSpaceObjectAfter: trueObj.
  self setHiddenRootsObj: (self oldSpaceObjectAfter: freeListObj).
  markStack := self swizzleObjStackAt: MarkStackRootIndex.
  weaklingStack := self swizzleObjStackAt: WeaklingStackRootIndex.
  mournQueue := self swizzleObjStackAt: MournQueueRootIndex.
  self assert: self validObjStacks.
  self assert: (self isEmptyObjStack: markStack).
  self assert: (self isEmptyObjStack: weaklingStack).
 
  self initializeFreeSpacePostLoad: freeListObj.
  segmentManager collapseSegmentsPostSwizzle.
+ self updateFreeLists.
  self computeFreeSpacePostSwizzle.
  compactor postSwizzleAction.
  self initializeOldSpaceFirstFree: freeOldSpaceStart. "initializes endOfMemory, freeStart, free space"
  self initializeNewSpaceVariables.
  scavenger initializeRememberedSet.
  segmentManager checkSegments.
  compactor biasForGC.
 
  "These defaults should depend on machine size; e.g. too small on a powerful laptop, too big on a Pi."
  growHeadroom := 16*1024*1024. "headroom when growing"
  shrinkThreshold := 32*1024*1024. "free space before shrinking"
  self setHeapSizeAtPreviousGC.
  heapGrowthToSizeGCRatio := 0.333333. "By default GC after scavenge if heap has grown by a third since the last GC"!

Item was changed:
  ----- Method: SpurMemoryManager>>isValidFreeObject: (in category 'free space') -----
  isValidFreeObject: objOop
  | chunk |
  ^(self addressCouldBeOldObj: objOop)
   and: [(self isFreeObject: objOop)
   and: [(self oop: (self addressAfter: objOop) isLessThanOrEqualTo: endOfMemory)
   and: [((chunk := (self fetchPointer: self freeChunkNextIndex ofFreeChunk: objOop)) = 0
    or: [self isFreeOop: chunk])
+  and: [((chunk := (self fetchPointer: self freeChunkPrevIndex ofFreeChunk: objOop)) = 0
+   or: [self isFreeOop: chunk])
   and: [(self isLargeFreeObject: objOop) not
     or: [((chunk := (self fetchPointer: self freeChunkParentIndex ofFreeChunk: objOop)) = 0
    or: [(self isFreeOop: chunk) and: [self isLargeFreeObject: chunk]])
   and: [((chunk := (self fetchPointer: self freeChunkSmallerIndex ofFreeChunk: objOop)) = 0
     or: [(self isFreeOop: chunk) and: [self isLargeFreeObject: chunk]])
   and: [(chunk := (self fetchPointer: self freeChunkLargerIndex ofFreeChunk: objOop)) = 0
+    or: [(self isFreeOop: chunk) and: [self isLargeFreeObject: chunk]]]]]]]]]]!
-    or: [(self isFreeOop: chunk) and: [self isLargeFreeObject: chunk]]]]]]]]]!

Item was removed:
- ----- Method: SpurMemoryManager>>rebuildFreeTreeFrom: (in category 'free space') -----
- rebuildFreeTreeFrom: sortedFreeChunks
- "post sweep and pre compact, rebuild the large free chunk tree from the
- sortedFreeChunks list, such that the lists are ordered from low to high address."
- | freeChunk bytes totalBytes |
- "first add all the chunks to the tree.  This will result in almost address-sorted lists.
- We will need to reorder the lists."
- freeChunk := sortedFreeChunks.
- totalBytes := 0.
- [freeChunk ~= 0] whileTrue:
- [bytes := self bytesInObject: freeChunk.
- totalBytes := totalBytes + bytes.
- self addToFreeTree: freeChunk bytes: bytes.
- freeChunk := self fetchPointer: self freeChunkNextAddressIndex
- ofFreeChunk: freeChunk].
- "now reorder the lists to ensure they're in address order, apart from the list head, which should be highest."
- self freeTreeNodesDo:
- [:treeNode| | newTreeNode |
- newTreeNode := self reorderReversedTreeList: treeNode.
- newTreeNode].
- ^totalBytes!

Item was removed:
- ----- Method: SpurMemoryManager>>reorderReversedTreeList: (in category 'free space') -----
- reorderReversedTreeList: treeNode
- "Once the freeTree has been rebuilt from the sortedFreeChunks list
- each list will be in a weird order, the list in reverse order, high to low,
- but the tree node, because it is inserted first, will be the lowest address.
- Reverse the list so it is sorted low to high, but make the highest address
- node the first, as this will be allocated from last."
- | first next node prev |
- "first becomes the new head, as this is the last one we want to allocate and we allocate from the list first."
- first := self fetchPointer: self freeChunkNextIndex ofFreeChunk: treeNode.
- "no next node, so no change"
- first = 0 ifTrue:
- [^treeNode].
- node := self fetchPointer: self freeChunkNextIndex ofFreeChunk: first.
- self storePointer: self freeChunkNextIndex ofFreeChunk: first withValue: treeNode.
- self inFreeTreeReplace: treeNode with: first.
- prev := 0.
- [node ~= 0] whileTrue:
- [next := self fetchPointer: self freeChunkNextIndex ofFreeChunk: node.
- self storePointer: self freeChunkNextIndex ofFreeChunk: node withValue: prev.
- prev := node.
- node := next].
- self storePointer: self freeChunkNextIndex ofFreeChunk: treeNode withValue: prev.
- ^first!

Item was removed:
- ----- Method: SpurMemoryManager>>reverseSmallListHeads (in category 'free space') -----
- reverseSmallListHeads
- "After freeUnmarkedObjectsNilUnmarkedWeaklingSlotsAndSortAndCoalesceFreeSpace
- all small free chunks will be on the free lists in reverse address order.  Reverse each list,
- summing the ammount of space.  Answer the sum of bytes of free space on these small lists."
- | total |
- total := 0.
- freeListsMask := 0.
- 1 to: self numFreeLists - 1 do:
- [:i| | bytes node prev next |
- bytes := i * self allocationUnit.
- node := freeLists at: i.
- node ~= 0 ifTrue:
- [self assert: (self bytesInObject: node) = bytes.
- freeListsMask := freeListsMask + (1 << i).
- prev := 0.
- [node ~= 0] whileTrue:
- [next := self fetchPointer: self freeChunkNextIndex ofFreeChunk: node.
- self storePointer: self freeChunkNextIndex ofFreeChunk: node withValue: prev.
- prev := node.
- node := next.
- total := total + bytes].
- freeLists at: i put: prev]].
- ^total!

Item was added:
+ ----- Method: SpurMemoryManager>>setNextFreeChunkOf:withValue:chunkBytes: (in category 'free space') -----
+ setNextFreeChunkOf: freeChunk withValue: nextFreeChunk chunkBytes: chunkBytes
+ <inline: true>
+ self
+ setNextFreeChunkOf: freeChunk
+ withValue: nextFreeChunk
+ sizeIsOne: chunkBytes / self wordSize = 1
+
+ !

Item was added:
+ ----- Method: SpurMemoryManager>>setNextFreeChunkOf:withValue:sizeIsOne: (in category 'free space') -----
+ setNextFreeChunkOf: freeChunk withValue: nextFreeChunk sizeIsOne: sizeIsOne
+ <inline: true> "Inlining is quite important since sizeIsOne is often false"
+ self
+ storePointer: self freeChunkNextIndex
+ ofFreeChunk: freeChunk
+ withValue: nextFreeChunk.
+ "In 32 bits, there's always enough room,
+ in 64 bits, size 1 is special."
+ (nextFreeChunk = 0 or: [sizeIsOne]) ifFalse:
+ [self
+ storePointer: self freeChunkPrevIndex
+ ofFreeChunk: nextFreeChunk
+ withValue: freeChunk]
+
+ !

Item was removed:
- ----- Method: SpurMemoryManager>>sortFreeListAt: (in category 'free space') -----
- sortFreeListAt: i
- "Sort the individual free list i so that the lowest address is at the head of the list.
- Use an insertion sort with a scan for initially sorted elements."
-
- | list next head |
- list := freeLists at: i. "list of objects to be inserted"
- list = 0 ifTrue: "empty list; we're done"
- [^self].
- head := list.
- "scan list to find find first out-of-order element"
- [(next := self fetchPointer: self freeChunkNextIndex ofFreeChunk: list) > list]
- whileTrue:
- [list := next].
- "no out-of-order elements; list was already sorted; we're done"
- next = 0 ifTrue:
- [^self].
- "detatch already sorted list"
- self storePointer: self freeChunkNextIndex ofFreeChunk: list withValue: 0.
- list := next.
- [list ~= 0] whileTrue:
- [| node prev |
- "grab next node to be inserted"
- next := self fetchPointer: self freeChunkNextIndex ofFreeChunk: list.
- "search sorted list for insertion point"
- prev := 0. "prev node for insertion sort"
- node := head. "current node for insertion sort"
- [node ~= 0
-  and: [self oop: node isLessThan: list]] whileTrue:
- [prev := node.
- node := self fetchPointer: self freeChunkNextIndex ofFreeChunk: node].
- "insert the node into the sorted list"
- self assert: (node = 0 or: [node > list]).
- prev = 0
- ifTrue:
- [head := list]
- ifFalse:
- [self storePointer: self freeChunkNextIndex
- ofFreeChunk: prev
- withValue: list].
- self storePointer: self freeChunkNextIndex
- ofFreeChunk: list
- withValue: node.
- list := next].
- "replace the list with the sorted list"
- freeLists at: i put: head!

Item was changed:
  ----- Method: SpurMemoryManager>>swizzleFieldsOfFreeChunk: (in category 'snapshot') -----
  swizzleFieldsOfFreeChunk: chunk
  <inline: true>
+ | field chunkBytes |
- | field |
  field := self fetchPointer: self freeChunkNextIndex ofFreeChunk: chunk.
  field ~= 0 ifTrue:
  [self storePointerNoAssert: self freeChunkNextIndex
  ofFreeChunk: chunk
  withValue: (segmentManager swizzleObj: field)].
+ (chunkBytes := self bytesInObject: chunk) / self wordSize = 1 ifFalse:
+ [field := self fetchPointer: self freeChunkPrevIndex ofFreeChunk: chunk.
+ field ~= 0 ifTrue:
+ [self storePointerNoAssert: self freeChunkPrevIndex
+ ofFreeChunk: chunk
+ withValue: (segmentManager swizzleObj: field)]].
+ chunkBytes >= (self numFreeLists * self allocationUnit) ifTrue:
- (self bytesInObject: chunk) >= (self numFreeLists * self allocationUnit) ifTrue:
  [self freeChunkParentIndex to: self freeChunkLargerIndex do:
  [:index|
  field := self fetchPointer: index ofFreeChunk: chunk.
  field ~= 0 ifTrue:
  [self storePointerNoAssert: index
  ofFreeChunk: chunk
  withValue: (segmentManager swizzleObj: field)]]]!

Item was changed:
  ----- Method: SpurMemoryManager>>totalFreeListBytes (in category 'free space') -----
  totalFreeListBytes
  "This method both computes the actual number of free bytes by traversing all free objects
  on the free lists/tree, and checks that the tree is valid.  It is used mainly by checkFreeSpace."
  | totalFreeBytes bytesInChunk listNode nextNode |
  totalFreeBytes := 0.
  1 to: self numFreeLists - 1 do:
  [:i|
  bytesInChunk := i * self allocationUnit.
  listNode := freeLists at: i.
  [listNode ~= 0] whileTrue:
  [totalFreeBytes := totalFreeBytes + bytesInChunk.
+ self
+ cCode: [self assert: (self isValidFreeObject: listNode)]
+ inSmalltalk: [self assertValidFreeObject: listNode].
- self assert: (self isValidFreeObject: listNode).
  self assert: bytesInChunk = (self bytesInObject: listNode).
  nextNode := self fetchPointer: self freeChunkNextIndex ofFreeChunk: listNode.
  self assert: nextNode ~= listNode.
  listNode := nextNode]].
 
  self freeTreeNodesDo:
  [:treeNode|
  bytesInChunk := self bytesInObject: treeNode.
  self assert: bytesInChunk / self allocationUnit >= self numFreeLists.
  listNode := treeNode.
  [listNode ~= 0] whileTrue:
  ["self printFreeChunk: listNode"
  self assert: (self isValidFreeObject: listNode).
  self assert: (listNode = treeNode
   or: [(self fetchPointer: self freeChunkParentIndex ofFreeChunk: listNode) = 0]).
  totalFreeBytes := totalFreeBytes + bytesInChunk.
  self assert: bytesInChunk = (self bytesInObject: listNode).
  nextNode := self fetchPointer: self freeChunkNextIndex ofFreeChunk: listNode.
  self assert: nextNode ~= listNode.
  listNode := nextNode].
  treeNode].
  ^totalFreeBytes!

Item was removed:
- ----- Method: SpurMemoryManager>>unlinkFreeChunk: (in category 'free space') -----
- unlinkFreeChunk: freeChunk
- "Unlink a free object from the free lists. Do not alter totalFreeOldSpace. Used for coalescing."
- | chunkBytes index node next prev child childBytes |
- index := (chunkBytes := self bytesInObject: freeChunk) / self allocationUnit.
- (index < self numFreeLists and: [1 << index <= freeListsMask]) ifTrue:
- [self assert: ((freeListsMask anyMask: 1 << index) and: [(freeLists at: index) ~= 0]).
- node := freeLists at: index.
- prev := 0.
- [node ~= 0] whileTrue:
- [self assert: node = (self startOfObject: node).
- self assert: (self isValidFreeObject: node).
- next := self fetchPointer: self freeChunkNextIndex ofFreeChunk: node.
- node = freeChunk ifTrue:
- [prev = 0
- ifTrue: [freeLists at: index put: next]
- ifFalse: [self storePointer: self freeChunkNextIndex ofFreeChunk: prev withValue: next].
- ^self].
- prev := node.
- node := next].
- self error: 'freeChunk not found in free lists'].
-
- "Large chunk.  Search the large chunk tree."
- child := freeLists at: 0.
- node := 0.
- [child ~= 0] whileTrue:
- [self assert: (self isValidFreeObject: child).
- childBytes := self bytesInObject: child.
- childBytes = chunkBytes ifTrue: "size match; try to remove from list at node."
- [node := child.
- [prev := node.
-  node := self fetchPointer: self freeChunkNextIndex ofFreeChunk: node.
-  node ~= 0] whileTrue:
- [node = freeChunk ifTrue:
- [self assert: (self isValidFreeObject: node).
- self storePointer: self freeChunkNextIndex
- ofFreeChunk: prev
- withValue: (self fetchPointer: self freeChunkNextIndex ofFreeChunk: node).
- ^self]].
- child = freeChunk ifTrue:
- [next := self fetchPointer: self freeChunkNextIndex ofFreeChunk: child.
- next = 0
- ifTrue: "no list; remove the interior node"
- [self unlinkSolitaryFreeTreeNode: child]
- ifFalse: "list; replace node with it"
- [self inFreeTreeReplace: child with: next].
- ^self]].
- child ~= 0 ifTrue:
- [childBytes < chunkBytes
- ifTrue: "node too small; walk down the larger size of the tree"
- [child := self fetchPointer: self freeChunkLargerIndex ofFreeChunk: child]
- ifFalse:
- [node := child.
- child := self fetchPointer: self freeChunkSmallerIndex ofFreeChunk: node]]].
-
- self error: 'freeChunk not found in free tree'
- !

Item was changed:
  ----- Method: SpurMemoryManager>>unlinkFreeChunk:atIndex: (in category 'free space') -----
  unlinkFreeChunk: chunk atIndex: index
  "Unlink and answer a small chunk from one of the fixed size freeLists"
  <inline: true>
+ |next|
  self assert: ((self bytesInObject: chunk) = (index * self allocationUnit)
  and: [index > 1 "a.k.a. (self bytesInObject: chunk) > self allocationUnit"
  and: [(self startOfObject: chunk) = chunk]]).
  freeLists
  at: index
+ put: (next := self
- put: (self
  fetchPointer: self freeChunkNextIndex
  ofFreeChunk: chunk).
+ next = 0 ifFalse: [self storePointer: self freeChunkPrevIndex ofFreeChunk: next withValue: 0].
  ^chunk!

Item was added:
+ ----- Method: SpurMemoryManager>>unlinkFreeChunk:chunkBytes: (in category 'free space') -----
+ unlinkFreeChunk: freeChunk chunkBytes: chunkBytes
+ "Unlink a free object from the free lists. Do not alter totalFreeOldSpace. Used for coalescing."
+ | index node next prev |
+ index := chunkBytes / self allocationUnit.
+
+ "Pathological 64 bits case - size 1 - single linked list"
+ chunkBytes / self wordSize = 1 ifTrue:
+ [node := freeLists at: index.
+ prev := 0.
+ [node ~= 0] whileTrue:
+ [self assert: node = (self startOfObject: node).
+ self assert: (self isValidFreeObject: node).
+ next := self fetchPointer: self freeChunkNextIndex ofFreeChunk: node.
+ node = freeChunk ifTrue:
+ [prev = 0
+ ifTrue: [freeLists at: index put: next]
+ ifFalse: [self setNextFreeChunkOf: prev withValue: next chunkBytes: chunkBytes].
+ ^self].
+ prev := node.
+ node := next].
+ self error: 'freeChunk not found in free list of size 1'].
+
+ prev := self fetchPointer: self freeChunkPrevIndex ofFreeChunk: freeChunk.
+ "Has prev element: update double linked list"
+ prev ~= 0 ifTrue:
+ [self
+ setNextFreeChunkOf: prev
+ withValue: (self fetchPointer: self freeChunkNextIndex ofFreeChunk: freeChunk)
+ chunkBytes: chunkBytes.
+ ^self].
+
+ "Is the beginning of a list"
+ "Small chunk"
+ (index < self numFreeLists and: [1 << index <= freeListsMask]) ifTrue: [
+ ^self unlinkFreeChunk: freeChunk atIndex: index].
+ "Large chunk"
+ next := self fetchPointer: self freeChunkNextIndex ofFreeChunk: freeChunk.
+ next = 0
+ ifTrue: "no list; remove the interior node"
+ [self unlinkSolitaryFreeTreeNode: freeChunk]
+ ifFalse: "list; replace node with it"
+ [self inFreeTreeReplace: freeChunk with: next]
+
+
+
+ !

Item was removed:
- ----- 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.
- 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 freeChunkParentIndex ofFreeChunk: next withValue: parent].
- 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>>updateFreeLists (in category 'initialization') -----
+ updateFreeLists
+ "Snapshot did not guarantee the state of the freelist prevLink, so we need to update it.
+ Effectively transforms the freechunk single linked list in double linked list."
+ |min|
+ "Small chunks"
+ "Skip in 64 bits size 1 which is single linked list - pathological case"
+ self allocationUnit / self wordSize = 1 ifTrue: [min := 2] ifFalse: [min := 1].
+ min to: self numFreeLists - 1 do:
+ [:i| self updateListStartingAt: (freeLists at: i)].
+ "Large chunks"
+ self freeTreeNodesDo: [:freeNode |
+ self updateListStartingAt: freeNode.
+ freeNode]!

Item was added:
+ ----- Method: SpurMemoryManager>>updateListStartingAt: (in category 'initialization') -----
+ updateListStartingAt: freeNode
+ |prev obj|
+ prev := freeNode.
+ self storePointer: self freeChunkPrevIndex ofFreeChunk: prev withValue: 0.
+ [obj := self fetchPointer: self freeChunkNextIndex ofFreeChunk: prev.
+ obj ~= 0] whileTrue:
+ [self storePointer: self freeChunkPrevIndex ofFreeChunk: obj withValue: prev.
+ prev := obj]!

Item was removed:
- SpurCompactor subclass: #SpurPigCompactor
- instanceVariableNames: 'firstFreeChunk lastFreeChunk numCompactionPasses'
- classVariableNames: 'CompactionPassesForGC CompactionPassesForSnapshot'
- poolDictionaries: ''
- category: 'VMMaker-SpurMemoryManager'!
-
- !SpurPigCompactor commentStamp: 'eem 12/16/2016 16:20' prior: 0!
- SpurPigCompactor implements the second compactioon algorithm implemented for Spur.  It attempts to move ovbjects down from the end of memory to occupy free chunks in low memory.  It uses Knuth's xor-encoding technique to encode a doubly-linked list in the forwarding field of each free chunk (free chunks, like Spiur objects, being known to have at least one field).  This algorithm has poor performance for two reasons.  First, it does not preserve object order, scrambling the order of objects as it moves the highest objects down to the lowest free chunks.  Second it appears to perform badly, occasionally causing very long pauses.
-
- Instance Variables
- coInterpreter: <StackInterpreter>
- firstFreeChunk: <Integer>
- lastFreeChunk: <Integer>
- manager: <SpurMemoryManager>
- numCompactionPasses: <Integer>
- scavenger: <SpurGenerationScavenger>
-
- firstFreeChunk
- - oop of freeChunk or 0
-
- lastFreeChunk
- - oop of freeChunk or 0
-
- numCompactionPasses
- - 2 for normal GC, 3 for snapshot!

Item was removed:
- ----- Method: SpurPigCompactor class>>initialize (in category 'class initialization') -----
- initialize
- "Pig compact can be repeated to compact better.  Experience shows that 3 times
- compacts very well, desirable for snapshots.  But this is overkill for normal GCs."
- CompactionPassesForGC := 2.
- CompactionPassesForSnapshot := 3!

Item was removed:
- ----- Method: SpurPigCompactor>>abstractPigCompaction (in category 'compaction - analysis') -----
- abstractPigCompaction
- "This method answers a rough estimate of compactibility using a pig (a large free chunk)."
- <doNotGenerate>
- | pig pork moved unmoved nmoved nunmoved |
- pig := self findAPig.
- pork := manager bytesInObject: pig.
- moved := unmoved := nmoved := nunmoved := 0.
- manager allOldSpaceObjectsFrom: pig do:
- [:o| | bytes |
- bytes := manager bytesInObject: o.
- bytes <= pork
- ifTrue:
- [moved := moved + bytes.
- nmoved := nmoved + 1.
- pork := pork - bytes]
- ifFalse:
- [unmoved := unmoved + bytes.
- nunmoved := nunmoved + 1]].
- ^{ manager bytesInObject: pig. pork. moved. nmoved. unmoved. nunmoved }!

Item was removed:
- ----- Method: SpurPigCompactor>>biasForGC (in category 'compaction - api') -----
- biasForGC
- numCompactionPasses := CompactionPassesForGC!

Item was removed:
- ----- Method: SpurPigCompactor>>biasForSnapshot (in category 'compaction - api') -----
- biasForSnapshot
- numCompactionPasses := CompactionPassesForSnapshot!

Item was removed:
- ----- Method: SpurPigCompactor>>checkNoForwardersBelowFirstFreeChunk (in category 'compaction - asserts') -----
- checkNoForwardersBelowFirstFreeChunk
- manager allOldSpaceEntitiesDo:
- [:o|
- (self oop: o isGreaterThanOrEqualTo: firstFreeChunk) ifTrue:
- [^true].
- (self asserta: (manager isForwarded: o) not) ifFalse:
- [^false]].
- ^true!

Item was removed:
- ----- Method: SpurPigCompactor>>checkTraversableSortedFreeList (in category 'compaction - asserts') -----
- checkTraversableSortedFreeList
- | prevFree prevPrevFree freeChunk |
- <api>
- <inline: false>
- prevFree := prevPrevFree := 0.
- firstFreeChunk = 0 ifTrue:
- [^lastFreeChunk = 0].
- freeChunk := firstFreeChunk.
- manager allOldSpaceEntitiesDo:
- [:o| | objOop next limit |
- (manager isFreeObject: o) ifTrue:
- [self assert: o = freeChunk.
- next := self nextInSortedFreeListLink: freeChunk given: prevFree.
- limit := next = 0 ifTrue: [manager endOfMemory] ifFalse: [next].
- "coInterpreter transcript cr; print: freeChunk; tab; print: o; tab; print: prevFree; nextPutAll: '<->'; print: next; flush."
- objOop := freeChunk.
- [self oop: (objOop := manager objectAfter: objOop) isLessThan: limit] whileTrue:
- [self assert: (manager isFreeObject: objOop) not].
- prevPrevFree := prevFree.
- prevFree := freeChunk.
- freeChunk := next]].
- self assert: prevFree = lastFreeChunk.
- self assert: (self nextInSortedFreeListLink: lastFreeChunk given: 0) = prevPrevFree.
- self assert: freeChunk = 0.
- ^true!

Item was removed:
- ----- Method: SpurPigCompactor>>compact (in category 'compaction - api') -----
- compact
- "We'd like to use exact fit followed by best or first fit, but it doesn't work
- well enough in practice.  So use pig compact.  Fill large free objects starting
- from low memory with objects taken from the end of memory."
- <inline: #never> "for profiling"
- self freeUnmarkedObjectsAndSortAndCoalesceFreeSpaceForPigCompact.
- manager statCompactPassCount: manager statCompactPassCount + 1.
- self assert: (firstFreeChunk = 0 or: [manager isFreeObject: firstFreeChunk]).
- 1 to: numCompactionPasses do:
- [:i|
- self pigCompact.
- self eliminateAndFreeForwardersForPigCompact].
-
- "The free lists are zeroed in freeUnmarkedObjectsAndSortAndCoalesceFreeSpaceForPigCompact.
- They should still be zero here"
- self assert: manager freeListHeadsEmpty.
- self rebuildFreeListsForPigCompact!

Item was removed:
- ----- Method: SpurPigCompactor>>eliminateAndFreeForwardersForPigCompact (in category 'compaction') -----
- eliminateAndFreeForwardersForPigCompact
- "As the final phase of global garbage collect, sweep the heap to follow
- forwarders, then free forwarders, coalescing with free space as we go."
- <inline: false>
- | lowestForwarder |
- <var: #lowestForwarder type: #usqInt>
- self assert: (manager isForwarded: manager nilObject) not.
- self assert: (manager isForwarded: manager falseObject) not.
- self assert: (manager isForwarded: manager trueObject) not.
- self assert: (manager isForwarded: manager freeListsObj) not.
- self assert: (manager isForwarded: manager hiddenRootsObject) not.
- self assert: (manager isForwarded: manager classTableFirstPage) not.
- manager followSpecialObjectsOop.
- manager followForwardedObjStacks.
- coInterpreter mapInterpreterOops.
- scavenger followRememberedForwardersAndForgetFreeObjectsForPigCompact.
- manager unmarkSurvivingObjectsForCompact.
- lowestForwarder := self sweepToFollowForwardersForPigCompact.
- self sweepToCoallesceFreeSpaceForPigCompactFrom: lowestForwarder.
- self assert: manager numberOfForwarders = 0!

Item was removed:
- ----- Method: SpurPigCompactor>>findAPig (in category 'compaction - analysis') -----
- findAPig
- "Answer a large low free chunk."
- <doNotGenerate>
- | pig |
- manager allObjectsInFreeTreeDo:
- [:f|
- (manager bytesInObject: f) >= 1000000 ifTrue:
- [(pig isNil or: [pig > f]) ifTrue:
- [pig := f]]].
- ^pig!

Item was removed:
- ----- Method: SpurPigCompactor>>freeUnmarkedObjectsAndSortAndCoalesceFreeSpaceForPigCompact (in category 'compaction') -----
- freeUnmarkedObjectsAndSortAndCoalesceFreeSpaceForPigCompact
- "Sweep all of old space, freeing unmarked objects, coalescing free chunks, and sorting free space.
-
- Doubly-link the free chunks in address order through the freeChunkNextIndex field using the
- xor trick to use only one field, see e.g.
- The Art of Computer Programming, Vol 1, D.E. Knuth, 3rd Ed, Sec 2.2.4 `Circular Lists', exercise. 18
- http://en.wikipedia.org/wiki/XOR_linked_list.
- Record the lowest free object in firstFreeChunk and the highest in lastFreeChunk.
-
- Let the segmentManager mark which segments contain pinned objects via notePinned:."
-
- | prevPrevFree prevFree |
- <inline: #never> "for profiling"
- manager checkFreeSpace: GCModeFull.
- "throw away the list heads, including the tree."
- manager resetFreeListHeads.
- firstFreeChunk := prevPrevFree := prevFree := 0.
- manager allOldSpaceEntitiesForCoalescingFrom: manager firstObject do:
- [:o|
- self assert: (firstFreeChunk = 0 or: [manager isFreeObject: firstFreeChunk]).
- (manager isMarked: o)
- ifTrue: "forwarders should have been followed in markAndTrace:"
- [self assert: (manager isForwarded: o) not.
- manager setIsMarkedOf: o to: false. "this will unmark bridges. undo the damage in notePinned:"
- (manager isPinned: o) ifTrue:
- [manager segmentManager notePinned: o]]
- ifFalse: "unmarked; two cases, an unreachable object or a free chunk."
- [| here |
- self assert: (manager isRemembered: o) not. "scavenger should have cleared this above"
- here := manager coallesceFreeChunk: o.
- manager setObjectFree: here.
- self inSortedFreeListLink: prevFree to: here given: prevPrevFree.
- prevPrevFree := prevFree.
- prevFree := here]].
- prevFree ~= firstFreeChunk ifTrue:
- [manager storePointer: manager freeChunkNextIndex
- ofFreeChunk: prevFree
- withValue: prevPrevFree].
- lastFreeChunk := prevFree.
- self inSortedFreeListLink: lastFreeChunk to: 0 given: prevPrevFree.
- self assert: self checkTraversableSortedFreeList!

Item was removed:
- ----- Method: SpurPigCompactor>>inSortedFreeListLink:to:given: (in category 'compaction') -----
- inSortedFreeListLink: freeChunk to: nextFree given: prevFree
- "Doubly-link the free chunk in address order through the freeChunkNextIndex field using the
-  xor trick to use only one field, see e.g.
- The Art of Computer Programming, Vol 1, D.E. Knuth, 3rd Ed, Sec 2.2.4 `Circular Lists', exercise. 18
- http://en.wikipedia.org/wiki/XOR_linked_list."
- freeChunk = 0
- ifTrue:
- [firstFreeChunk := nextFree]
- ifFalse:
- [manager storePointer: manager freeChunkNextIndex
- ofFreeChunk: freeChunk
- withUncheckedValue: (prevFree bitXor: nextFree)]!

Item was removed:
- ----- Method: SpurPigCompactor>>moveARunOfObjectsStartingAt:upTo: (in category 'compaction') -----
- moveARunOfObjectsStartingAt: startAddress upTo: limit
- "Move the sequence of movable objects starting at startAddress.  Answer the start
- of the next sequence of movable objects after a possible run of unmovable objects,
- or the limit, if there are no more movable objects, or 0 if no more compaction can be
- done. Compaction is done when the search through the freeList has reached the
- address from which objects are being moved from.
-
- There are two broad cases to be dealt with here.  One is a run of smallish objects
- that can easily be moved into free chunks.  The other is a large object that is unlikely
- to fit in the typical free chunk. This second pig needs careful handling; it needs to be
- moved to the lowest place it will fit and not cause the scan to skip lots of smaller
- free chunks looking in vain for somewhere to put it."
- <var: #startAddress type: #usqInt>
- <var: #limit type: #usqInt>
- <inline: false>
- | here hereObj hereObjHeader prevPrevFreeChunk prevFreeChunk thisFreeChunk maxFreeChunk |
- <var: #here type: #usqInt>
- <var: #there type: #usqInt>
- <var: #nextFree type: #usqInt>
- <var: #endOfFree type: #usqInt>
- <var: #destination type: #usqInt>
- <var: #maxFreeChunk type: #usqInt>
- here := startAddress.
- hereObj := manager objectStartingAt: startAddress.
- hereObjHeader := manager atLeastClassIndexHalfHeader: hereObj.
- prevPrevFreeChunk := prevFreeChunk := 0.
- thisFreeChunk := maxFreeChunk := firstFreeChunk.
- [thisFreeChunk ~= 0] whileTrue:
- [| freeBytes endOfFree nextFree destination there moved |
-
- "skip any initial immobile objects"
- [(manager isMobileObjectHeader: hereObjHeader)] whileFalse:
- [here := manager addressAfter: hereObj.
- here >= limit ifTrue:
- [^maxFreeChunk >= startAddress ifTrue: [0] ifFalse: [limit]].
- hereObj := manager objectStartingAt: here.
- hereObjHeader := manager atLeastClassIndexHalfHeader: hereObj].
-
- "grab a free chunk, and the following one, because we want to overwrite this one."
- self assert: ((manager isFreeObject: firstFreeChunk) and: [manager isFreeObject: thisFreeChunk]).
- freeBytes := manager bytesInObject: thisFreeChunk.
- nextFree := self nextInSortedFreeListLink: thisFreeChunk given: prevFreeChunk.
- destination := manager startOfObject: thisFreeChunk.
- endOfFree := destination + freeBytes.
- moved := false.
- maxFreeChunk := maxFreeChunk max: nextFree.
- self assert: (nextFree = 0 or: [manager isFreeObject: nextFree]).
-
- "move as many objects as will fit in freeBytes..."
- [there := manager addressAfter: hereObj.
-  "N.B. *must* add allocationUnit, not subtract, to avoid unsigned arithmetic issues when freeBytes = 0"
-  (manager isMobileObjectHeader: hereObjHeader)
-  and: [freeBytes > (there - here + manager allocationUnit)
-    or: [freeBytes = (there - here)]]] whileTrue:
- [moved := true.
- manager mem: destination asVoidPointer cp: here asVoidPointer y: there - here.
- manager forwardUnchecked: hereObj to: destination + (hereObj - here).
- destination := destination + (there - here).
- freeBytes := freeBytes - (there - here).
- hereObj := manager objectStartingAt: there.
- here := there.
- hereObjHeader := manager atLeastClassIndexHalfHeader: hereObj].
-
- moved
- ifTrue: "we did overwrite it; we need to repair the free list"
- [| nextNextFree |
- nextFree ~= 0 ifTrue:
- [nextNextFree  := self nextInSortedFreeListLink: nextFree given: thisFreeChunk.
- self assert: (manager isFreeObject: nextFree)].
- (destination > thisFreeChunk "if false couldn't move anything"
-  and: [destination < endOfFree]) "if false, filled entire free chunk"
- ifTrue:
- [thisFreeChunk := manager initFreeChunkWithBytes: endOfFree - destination at: destination.
- self inSortedFreeListLink: prevFreeChunk to: thisFreeChunk given: prevPrevFreeChunk.
- self inSortedFreeListLink: thisFreeChunk to: nextFree given: prevFreeChunk.
- nextFree ~= 0 ifTrue:
- [self inSortedFreeListLink: nextFree to: nextNextFree given: thisFreeChunk].
- prevPrevFreeChunk := prevFreeChunk.
- prevFreeChunk := thisFreeChunk.
- thisFreeChunk := nextFree]
- ifFalse:
- [self inSortedFreeListLink: prevFreeChunk to: nextFree given: prevPrevFreeChunk.
- nextFree ~= 0 ifTrue:
- [self inSortedFreeListLink: nextFree to: nextNextFree given: prevFreeChunk].
- thisFreeChunk := nextFree]]
- ifFalse: "out of space (or immobile object); move on up the free list..."
- [prevPrevFreeChunk := prevFreeChunk.
- prevFreeChunk := thisFreeChunk.
- thisFreeChunk := nextFree].
-
- (manager isMobileObjectHeader: hereObjHeader) ifFalse:
- [^maxFreeChunk >= startAddress ifTrue: [0] ifFalse: [there]].
-
- "Was the loop stopped by a pig? If so, try and find space for it"
- there - here >= (manager averageObjectSizeInBytes * 8) ifTrue: "256b in 32 bit, 512b in 64 bit"
- [| usedChunk |
- usedChunk := self tryToMovePig: hereObj at: here end: there.
- "if it couldn't be moved we need to advance, so always
- set here to there whether the pig was moved or not."
- hereObj := manager objectStartingAt: there.
- here := there.
- hereObjHeader := manager atLeastClassIndexHalfHeader: hereObj.
- "In general it's a bad idea to reset the enumeration; it leads to N^2 behaviour
-  when encountering pigs.  But if the move affected the enumeration this is
-  simpler than resetting the list pointers."
- (usedChunk = prevPrevFreeChunk
-  or: [usedChunk = prevFreeChunk
-  or: [usedChunk = thisFreeChunk]]) ifTrue:
- ["reset the scan for free space back to the start of the list"
- prevPrevFreeChunk := prevFreeChunk := 0.
- thisFreeChunk := firstFreeChunk]].
-
- ((here > startAddress and: [there >= limit])
- or: [maxFreeChunk >= startAddress]) ifTrue:
- [^maxFreeChunk >= startAddress ifTrue: [0] ifFalse: [there]]].
- ^here!

Item was removed:
- ----- Method: SpurPigCompactor>>nextInSortedFreeListLink:given: (in category 'compaction') -----
- nextInSortedFreeListLink: freeChunk given: prevFree
- "Answer the next free free chunk using the xor trick to use only one field, see e.g.
- The Art of Computer Programming, Vol 1, D.E. Knuth, 3rd Ed, Sec 2.2.4 `Circular Lists', exercise. 18
- http://en.wikipedia.org/wiki/XOR_linked_list."
- <inline: true>
- ^((manager fetchPointer: manager freeChunkNextIndex ofFreeChunk: freeChunk) bitXor: prevFree) asUnsignedInteger!

Item was removed:
- ----- Method: SpurPigCompactor>>noForwardersBelowFirstFreeChunk (in category 'compaction - asserts') -----
- noForwardersBelowFirstFreeChunk
- manager allOldSpaceEntitiesDo:
- [:o|
- (self oop: o isGreaterThanOrEqualTo: firstFreeChunk) ifTrue:
- [^true].
- (manager isForwarded: o) ifTrue:
- [^false]].
- ^true!

Item was removed:
- ----- Method: SpurPigCompactor>>pigCompact (in category 'compaction') -----
- pigCompact
- "Traverse the sorted free list, moving objects from the high-end of
- memory to the free objects in the low end of memory.  Return when
- the address at which objects are being copied to meets the address
- from which objects are being copied from."
- self cCode: '' inSmalltalk: [coInterpreter transcript nextPutAll: 'pig compacting...'; flush].
- self sortedFreeListPairwiseReverseDo:
- [:low :high| | scanAddress |
- self cCode: '' inSmalltalk: [coInterpreter transcript nextPut: $.; flush].
- scanAddress := manager addressAfter: low.
- [self oop: scanAddress isLessThan: high] whileTrue:
- [scanAddress := self moveARunOfObjectsStartingAt: scanAddress upTo: high.
- scanAddress = 0 ifTrue:
- [^self]]].
- self assert: self checkTraversableSortedFreeList!

Item was removed:
- ----- Method: SpurPigCompactor>>printSortedFreeList (in category 'debug printing') -----
- printSortedFreeList
- <api>
- | freeChunk prevFree nextFree |
- (firstFreeChunk > 0 and: [lastFreeChunk > firstFreeChunk]) ifFalse:
- [coInterpreter print: 'sorted free list empty or corrupt'; cr.
- ^self].
- freeChunk := firstFreeChunk.
- prevFree := 0.
- [((manager addressCouldBeObj: freeChunk)
- and: [manager isFreeObject: freeChunk]) ifFalse:
- [coInterpreter printHexnp: freeChunk; print: ' is not a free chunk!!' ; cr.
- ^self].
- manager printFreeChunk: freeChunk printAsTreeNode: false.
- freeChunk ~= lastFreeChunk] whileTrue:
- [nextFree := self nextInSortedFreeListLink: freeChunk given: prevFree.
- prevFree := freeChunk.
- freeChunk := nextFree]!

Item was removed:
- ----- Method: SpurPigCompactor>>rebuildFreeListsForPigCompact (in category 'compaction') -----
- rebuildFreeListsForPigCompact
- "Rebuild the free lists from the doubly-linked free list."
- <inline: false>
- self assert: self checkTraversableSortedFreeList.
- manager totalFreeOldSpace: 0.
- self sortedFreeListDo:
- [:freeObj| | start bytes |
- bytes := (manager bytesInObject: freeObj).
- start := manager startOfObject: freeObj.
- manager addFreeChunkWithBytes: bytes at: start].
- manager checkFreeSpace: GCModeFull!

Item was removed:
- ----- Method: SpurPigCompactor>>sortedFreeListDo: (in category 'compaction') -----
- sortedFreeListDo: aBlock
- "Evaluate aBlock with ascending entries in the free list"
- | free nextFree prevFree prevPrevFree |
- <var: #free type: #usqInt>
- <var: #nextFree type: #usqInt>
- <var: #prevFree type: #usqInt>
- <var: #prevPrevFree type: #usqInt>
- <inline: true>
- free := firstFreeChunk.
- prevPrevFree := prevFree := 0.
- [free ~= 0] whileTrue:
- [nextFree := self nextInSortedFreeListLink: free given: prevFree.
- self assert: (manager isFreeObject: free).
- self assert: (nextFree = 0 or: [nextFree > free and: [manager isFreeObject: nextFree]]).
- self assert: (prevFree = 0 or: [prevFree < free]).
- aBlock value: free.
- prevPrevFree := prevFree.
- prevFree := free.
- free := nextFree]!

Item was removed:
- ----- Method: SpurPigCompactor>>sortedFreeListPairwiseReverseDo: (in category 'compaction') -----
- sortedFreeListPairwiseReverseDo: aBinaryBlock
- "Evaluate aBinaryBlock with adjacent entries in the free list, from
- high address to low address.  The second argument is in fact the
- start of the next free chunk, not the free chunk itself.  Use
- endOfMemory - bridgeSize as the second argument in the first evaluation."
- | free prevFree prevPrevFree |
- <var: #free type: #usqInt>
- <var: #prevFree type: #usqInt>
- <var: #prevPrevFree type: #usqInt>
- <inline: true>
- free := lastFreeChunk.
- prevPrevFree := prevFree := 0.
- [free ~= 0] whileTrue:
- [aBinaryBlock value: free value: (prevFree = 0
- ifTrue: [manager endOfMemory - manager bridgeSize]
- ifFalse: [manager startOfObject: prevFree]).
- "post evaluation of aBinaryBlock the value of free may be invalid
-  because moveARunOfObjectsStartingAt:upTo: may have filled it.
-  So reconstruct the position in the enumeration."
- prevFree = 0
- ifTrue:
- [self assert: free = lastFreeChunk.
- prevFree := lastFreeChunk.
- free := self nextInSortedFreeListLink: lastFreeChunk given: 0]
- ifFalse:
- [self assert: (manager isFreeObject: prevFree).
- prevPrevFree = 0
- ifTrue:
- [prevPrevFree := lastFreeChunk.
- prevFree := self nextInSortedFreeListLink: lastFreeChunk given: 0]
- ifFalse:
- [self assert: (manager isFreeObject: prevPrevFree).
- free := self nextInSortedFreeListLink: prevFree given: prevPrevFree.
- prevPrevFree := prevFree.
- prevFree := free].
- free := self nextInSortedFreeListLink: prevFree given: prevPrevFree]]!

Item was removed:
- ----- Method: SpurPigCompactor>>sweepToCoallesceFreeSpaceForPigCompactFrom: (in category 'compaction') -----
- sweepToCoallesceFreeSpaceForPigCompactFrom: lowestForwarder
- "Coallesce free chunks and forwarders, maintaining the doubly-linked free list."
- | lowest firstOfFreeRun startOfFreeRun endOfFreeRun prevPrevFree prevFree |
- <var: #lowestForwarder type: #usqInt>
- lowest := (lowestForwarder = 0 ifTrue: [manager endOfMemory] ifFalse: [lowestForwarder])
- min: (firstFreeChunk = 0 ifTrue: [manager endOfMemory] ifFalse: [firstFreeChunk]).
- firstOfFreeRun := prevPrevFree := prevFree := 0.
- manager allOldSpaceEntitiesFrom: lowest do:
- [:o|
- ((manager isFreeObject: o) or: [manager isForwarded: o])
- ifTrue:
- [firstOfFreeRun = 0 ifTrue:
- [manager setObjectFree: o.
- firstOfFreeRun := o.
- startOfFreeRun := manager startOfObject: o].
- endOfFreeRun := o]
- ifFalse:
- [firstOfFreeRun ~= 0 ifTrue:
- [| bytes |
- bytes := (manager addressAfter: endOfFreeRun) - startOfFreeRun.
- firstOfFreeRun := manager initFreeChunkWithBytes: bytes at: startOfFreeRun.
- self inSortedFreeListLink: prevFree to: firstOfFreeRun given: prevPrevFree.
- prevPrevFree := prevFree.
- prevFree := firstOfFreeRun.
- firstOfFreeRun := 0]]].
- firstOfFreeRun ~= 0 ifTrue:
- [| bytes |
- bytes := (manager addressAfter: endOfFreeRun) - startOfFreeRun.
- firstOfFreeRun := manager initFreeChunkWithBytes: bytes at: startOfFreeRun.
- self inSortedFreeListLink: prevFree to: firstOfFreeRun given: prevPrevFree.
- prevPrevFree := prevFree.
- prevFree := firstOfFreeRun.
- firstOfFreeRun := 0].
- prevFree ~= firstFreeChunk ifTrue:
- [manager storePointer: manager freeChunkNextIndex
- ofFreeChunk: prevFree
- withValue: prevPrevFree].
- lastFreeChunk := prevFree.
- self inSortedFreeListLink: lastFreeChunk to: 0 given: prevPrevFree.
- self assert: self checkTraversableSortedFreeList!

Item was removed:
- ----- Method: SpurPigCompactor>>sweepToFollowForwardersForPigCompact (in category 'compaction') -----
- sweepToFollowForwardersForPigCompact
- "Sweep, following forwarders in all live objects.
- Answer the lowest forwarder in oldSpace."
- | lowestForwarder |
- <var: #lowestForwarder type: #usqInt>
- self assert: (manager freeStart = scavenger eden start
-  and: [scavenger futureSurvivorStart = scavenger futureSpace start]).
- manager allPastSpaceObjectsDo:
- [:o|
- (manager isForwarded: o) ifFalse:
- [0 to: (manager numPointerSlotsOf: o) - 1 do:
- [:i| | f |
- f := manager fetchPointer: i ofObject: o.
- (manager isOopForwarded: f) ifTrue:
- [f := manager followForwarded: f.
- manager storePointerUnchecked: i ofObject: o withValue: f]]]].
- lowestForwarder := 0.
- manager allOldSpaceObjectsDo:
- [:o|
- (manager isForwarded: o)
- ifTrue:
- [lowestForwarder = 0 ifTrue:
- [lowestForwarder := o]]
- ifFalse:
- [0 to: (manager numPointerSlotsOf: o) - 1 do:
- [:i| | f |
- f := manager fetchPointer: i ofObject: o.
- (manager isOopForwarded: f) ifTrue:
- [f := manager followForwarded: f.
- manager storePointer: i ofObject: o withValue: f]]]].
- ^lowestForwarder!

Item was removed:
- ----- Method: SpurPigCompactor>>tryToMovePig:at:end: (in category 'compaction') -----
- tryToMovePig: pigObj at: pigStart end: pigEnd
- "Try to move a pig (a largish object) to a free chunk in low memory.
- Answer the freeChunk that was used to house the moved pig, or
- 0 if no free chunk could be found."
- | freeChunk prevFree prevPrevFree pigBytes nextNext |
- prevPrevFree := prevFree := 0.
- freeChunk := firstFreeChunk.
- pigBytes := pigEnd - pigStart.
- [freeChunk ~= 0 and: [freeChunk < pigObj]] whileTrue:
- [| next dest chunkBytes newChunk |
- next := self nextInSortedFreeListLink: freeChunk given: prevFree.
- dest := manager startOfObject: freeChunk.
- chunkBytes := (manager addressAfter: freeChunk) - dest.
- "N.B. *must* add allocationUnit, not subtract, to avoid unsigned arithmetic issues when chunkBytes = 0"
- (chunkBytes = pigBytes
-  or: [chunkBytes > (pigBytes + manager allocationUnit)]) ifTrue:
- [manager mem: dest asVoidPointer cp: pigStart asVoidPointer y: pigBytes.
- manager forwardUnchecked: pigObj to: dest + (pigObj - pigStart).
- next ~= 0 ifTrue:
- [nextNext  := self nextInSortedFreeListLink: next given: freeChunk].
- "now either shorten the chunk, or remove it, adjusting the links to keep the list sorted."
- pigBytes < chunkBytes "if false, filled entire free chunk"
- ifTrue:
- [newChunk := manager initFreeChunkWithBytes: chunkBytes - pigBytes at: dest + pigBytes.
- self inSortedFreeListLink: prevFree to: newChunk given: prevPrevFree.
- self inSortedFreeListLink: newChunk to: next given: prevFree.
- next ~= 0 ifTrue:
- [self inSortedFreeListLink: next to: nextNext given: newChunk]]
- ifFalse:
- [self inSortedFreeListLink: prevFree to: next given: prevPrevFree.
- next ~= 0 ifTrue:
- [self inSortedFreeListLink: next to: nextNext given: prevFree]].
- "self checkTraversableSortedFreeList".
- ^freeChunk].
- prevPrevFree := prevFree.
- prevFree := freeChunk.
- freeChunk := next].
- ^0!

Item was changed:
  ----- Method: SpurPlanningCompactor>>coalesceFrom: (in category 'private') -----
  coalesceFrom: maybeStartOfFree
  "manager printOopsFrom: maybeStartOfFree to: manager endOfMemory"
  <var: 'maybeStartOfFree' type: #usqInt>
+ |obj next objBytes nextBytes|
- | obj next |
  <var: 'obj' type: #usqInt>
  <var: 'next' type: #usqInt>
  maybeStartOfFree >= manager endOfMemory ifTrue:
  [^self].
  obj := manager objectStartingAt: maybeStartOfFree.
  [next := manager oldSpaceObjectAfter: obj.
  next < manager endOfMemory] whileTrue:
  [((manager isFreeObject: obj) and: [manager isFreeObject: next])
  ifTrue:
+ [objBytes := manager bytesInObject: obj.
+ nextBytes := manager bytesInObject: next.
+ manager unlinkFreeChunk: obj chunkBytes: objBytes.
+ manager unlinkFreeChunk: next chunkBytes: nextBytes.
+ obj := manager freeChunkWithBytes: objBytes + nextBytes at: (manager startOfObject: obj)]
- [manager unlinkFreeChunk: obj.
- manager unlinkFreeChunk: next.
- obj := manager freeChunkWithBytes: (manager bytesInObject: obj) + (manager bytesInObject: next) at: (manager startOfObject: obj)]
  ifFalse:
  [obj := next]]!

Item was changed:
  ----- Method: SpurSelectiveCompactor>>globalSweepAndSegmentOccupationAnalysis (in category 'sweep phase') -----
  globalSweepAndSegmentOccupationAnalysis
  self internalGlobalSweepAndSegmentOccupationAnalysis.
  manager checkFreeSpace: GCModeFull.
+ manager unmarkSurvivingObjectsForCompact.
+ self cCode: '' inSmalltalk: [manager freeTreeOverlapCheck].!
- manager unmarkSurvivingObjectsForCompact.!

Item was changed:
  ----- Method: SpurSelectiveCompactor>>selectiveCompaction (in category 'compaction') -----
  selectiveCompaction
  "Figures out which segments to compact and compact them into segmentToFill"
  | atLeastOneSegmentToCompact |
  self assertNoSegmentBeingCompacted.
  atLeastOneSegmentToCompact := self computeSegmentsToCompact.
  "If no compaction we don't pay forwarding cost (stack scan, cache scan, etc.)
  and we don't allocate segmentToFill if none available."
  atLeastOneSegmentToCompact
  ifTrue:
  [self assert: segmentToFill ~~ nil.
+ self compactSegmentsToCompact.
+ self cCode: '' inSmalltalk: [manager freeTreeOverlapCheck].].
- self compactSegmentsToCompact].
  manager checkFreeSpace: GCModeFull.!

Item was changed:
  ----- Method: SpurSweeper>>globalSweep (in category 'sweep phase') -----
  globalSweep
  "Iterate over all entities, in order, if the entity is a free chunk or unmarked object,
  make a new big piece of free chunk, else unmark the object which stay live."
 
  | currentEntity start |
  currentEntity := manager firstObject.
  [self oop: currentEntity isLessThan: manager endOfMemory] whileTrue:
  [(self canUseAsFreeSpace: currentEntity)
  ifTrue: ["bulkFreeChunkFrom: may change a 1 word header
  object to a double word header object"
  start := manager startOfObject: currentEntity.
  self bulkFreeChunkFrom: currentEntity.
  currentEntity := manager objectStartingAt: start]
  ifFalse: [self unmark: currentEntity].
  currentEntity := manager objectAfter: currentEntity limit: manager endOfMemory].
 
  manager checkFreeSpace: GCModeFull.
 
  manager unmarkSurvivingObjectsForCompact.
+
+ self cCode: '' inSmalltalk: [manager freeTreeOverlapCheck].
  !