"Squeak-derived GC object layout." ObjectHeader addPackedElementNamed: #isMarked size: 1. ObjectHeader addPackedElementNamed: #isWeak size: 1. ObjectHeader addPackedElementNamed: #isRoot size: 1. ObjectHeader addPackedElementNamed: #idHash size: 21. ObjectHeader addPackedElementNamed: #objectSize size: 8. obj@(Object pointer) mark [obj header isMarked: True. ] inline export. obj@(Object pointer) unmark [obj header isMarked: False. ] inline export. oop@ObjectPointer targetSize [ oop pointer totalSize / 4 ]!UnsignedLongInt inline export. addConstantNamed: #ObjectHeaderSize valued: 1. addConstantNamed: #MarkMask valued: 2r001. addConstantNamed: #WeakMask valued: 2r010. addConstantNamed: #RootMask valued: 2r100. addConstantNamed: #HashMask valued: 16r00FFFFF8. addConstantNamed: #HashShift valued: 2. addConstantNamed: #SizeMask valued: 16rFF000000. addConstantNamed: #SizeShift valued: 24. addConstantNamed: #FreeMask valued: (HashMask init bitOr: SizeMask init). "The mask for the area of the header word where the free offset info is stored." "Garbage Collection" ObjectHeap addElementNamed: #youngStart. ObjectHeap addElementNamed: #youngStartLocal. ObjectHeap addElementNamed: #allocationCount. ObjectHeap addElementNamed: #allocationAmount. ObjectHeap addElementNamed: #tenuringThreshold. ObjectHeap addElementNamed: #allocationsBetweenCollections. ObjectHeap addElementNamed: #maxAllocationBetweenCollections. ObjectHeap addElementNamed: #freeBlock. "Objects in this buffer are remapped when a compaction occurs. This facility is used by the interpreter to ensure that objects in temporary variables are properly remapped." ObjectHeap addElementNamed: #remapBuffer type: Array pointer. ObjectHeap addElementNamed: #remapBufferCount. "The number of objects currently in the remapBuffer." "GC statistics." ObjectHeap addElementNamed: #statFullGCs. ObjectHeap addElementNamed: #statFullGCMSecs. ObjectHeap addElementNamed: #statIncrGCs. ObjectHeap addElementNamed: #statIncrGCMSecs. ObjectHeap addElementNamed: #statTenures. ObjectHeap addElementNamed: #statRootTableOverflows. h@(ObjectHeap pointer) initializeWithFirstFreeAt: firstFree "Initialize memoryEnd to the top of oop storage space, reserving some space for forwarding blocks, and create the freeBlock from which space is allocated. Also create a fake free chunk at memoryEnd to act as a sentinel for memory scans." [| firstFree!ObjectPointer fwdBlockBytes | h memoryLimit: limit - 24. "Remove a little for safety. FIX ME: Why does this need to happen?" "Reserve space for forwarding blocks." fwdBlockBytes: (h totalObjectCount bitAnd: (2 << 31) - (2 << 1)). "Reserve enough space for a minimal free block of ObjectHeaderSize bytes." h memoryLimit - fwdBlockBytes >= (firstFree + ObjectHeaderSize) ifFalse: [fwdBlockBytes: h memoryLimit - (firstFree + ObjectHeaderSize)]. h memoryEnd: (h memoryLimit - fwdBlockBytes). h freeBlock: firstFree. h setSizeOfFree: h freeBlock to: h memoryEnd - firstFree. h freeBlock < h memoryEnd /\ (h memoryEnd < h memoryLimit) ifFalse: [error: 'The computation of free space is incorrect.']. (h objectAfter: h freeBlock) = h memoryEnd ifFalse: [error: 'The free block was not properly initialized.']. ]. h@(ObjectHeap pointer) initializeCollector "Initialization redefines memoryEnd to be the end of the object allocation area based on the total available memory, but reserving some space for forwarding blocks." [ h youngStart: h memoryEnd. h rootsCount: 0. h allocationCount: 0. h allocationAmount: 0. h lowSpaceThreshold: 0. h compStart: 0. h compEnd: 0. h allocationsBetweenCollections: 4000. "How many object allocations can occur before another incremental GC." h maxAllocationBetweenCollections: 8 << 20. "8 MB allocated in any case will trigger another incremental GC; should be proportional to startup memory / default memory size." h tenuringThreshold: 2000. "Tenure all surviving objects if the count exceeds this threshold." "GC statistics." h statFullGCs: 0. h statFullGCMSecs: 0. h statIncrGCs: 0. h statIncrGCMSecs: 0. h statTenures: 0. h statRootTableOverflows: 0. h initializeWithFirstFreeAt: h memoryEnd. ]. h@(ObjectHeap pointer) isYoung: oop "Answer whether the oop is in young object space." [| oop!ObjectPointer | oop >= h youngStart ]!Bool inline export. h@(ObjectHeap pointer) isOld: oop "Answer whether the oop is not in young object space." [| oop!ObjectPointer | oop < h youngStart ]!Bool inline export. h@(ObjectHeap pointer) isFree: oop "Answer whether the oop represents a free area of the heap; this is determined by whether the weak bit is set in the header." [| oop!ObjectPointer | (h at: oop)!ObjectHeader isWeak ]!Bool inline export. h@(ObjectHeap pointer) lowestFreeAfter: chunk "Answer the first free block after the given chunk in memory." [| chunk!ObjectPointer oop!ObjectPointer oopHeader!ObjectHeader | oop: chunk. [oop < h memoryEnd] whileTrue: [oopHeader: (h at: oop)!ObjectHeader. oopHeader isWeak ifTrue: [^ oop]. "Means it's free; see isFree:." oop: oop + oopHeader objectSize]. error: 'Finding at least one free object was expected.'. ]!ObjectPointer. h@(ObjectHeap pointer) sizeOfFree: oop "Answer the size of the given chunk in words. ASSUME: The argument MUST be a free chunk." [| oop!ObjectPointer | oop pointer header bitAnd: FreeMask ]!UnsignedLongInt. h@(ObjectHeap pointer) setSizeOfFree: oop to: wordSize "Set the header of the given chunk to make it be a free chunk of the given size." [| oop!ObjectPointer wordSize | oop pointer header: ((wordSize bitAnd: FreeMask) bitOr: WeakMask) ]!UnsignedLongInt. h@(ObjectHeap pointer) sizeOfFreeBlock [ h sizeOfFree: h freeBlock ]!UnsignedLongInt. h@(ObjectHeap pointer) objectAfter: oop "Return the object or free chunk immediately following the given object or free chunk in memory. Answer memoryEnd when enumeration is complete. " [| oop!ObjectPointer sz | oop >= h memoryEnd ifTrue: [error: 'No objects after the end of memory']. (h isFree: oop) ifTrue: [sz: (h sizeOfFree: oop)] ifFalse: [sz: oop totalSize]. oop + sz ]!ObjectPointer. "The Roots table:" addConstantNamed: #RootTableSize valued: 2500. addConstantNamed: #RootTableSoftLimit valued: RootTableSize init - 100. ObjectHeap addElementNamed: #rootsCount. ObjectHeap addElementNamed: #rootTable type: (Array of: UnsignedLongInt) pointer. h@(ObjectHeap pointer) hasRoot: oop "Checks the root table for the given oop, and returns whether it's present. NOTE: This takes O(n) in the worst case. TODO: return position or -1?." [| oop!ObjectPointer rc | rc: h rootsCount. 0 below: rc do: [| :index | (h rootTable at: index) = oop ifTrue: [^ True]]. False ]!Bool. h@(ObjectHeap pointer) includeRoot: oop headerAt: hdrOop "Record that the given oop in the old object area points to an object in the young area. hdrOop is usually = oop, but may be an address in a forwarding block." [| oop!ObjectPointer hdrOop!ObjectPointer header!ObjectHeader | header: (h at: hdrOop)!ObjectHeader. header isRoot ifFalse: ["Whether the roots table has enough space." h rootsCount < RootTableSoftLimit ifTrue: [h rootsCount: h rootsCount + 1. h rootTable at: h rootsCount put: oop] ifFalse: "The soft limit has been exceeded." [h rootsCount < RootTableSize ifTrue: "There's still space to record it." [h rootsCount: h rootsCount + 1. h rootTable at: h rootsCount put: oop. header isRoot: True. "Force an incremental GC before the next allocation." h allocationCount: h allocationsBetweenCollections + 1]]]. ]. h@(ObjectHeap pointer) possibleRootStoreInto: oop value: valueOop "If valueOop is young, mark the object as a root." "ASSUME: oop is an old object." [| oop!ObjectPointer valueOop!ObjectPointer | (h isYoung: valueOop) /\ valueOop isSmallInt not ifTrue: [h includeRoot: oop headerAt: oop]. ]. h@(ObjectHeap pointer) markRootIfOld: oop "If the object is old, mark it as a root, since a new object may be stored into it." [| oop!ObjectPointer | (h isOld: oop) /\ oop isSmallInt not ifTrue: [h includeRoot: oop headerAt: oop]. ]. h@(ObjectHeap pointer) validateRoots "Answer (and verify) that every old object that points to a new object appears in the rootTable. This method should not be called if the rootTable is full, because roots are no longer recorded, and incremental collections are not attempted. This routine will merely return True in that case." [| oop!ObjectPointer fieldAddr fieldOop!ObjectPointer header!ObjectHeader badRoot!Bool | badRoot: False. oop: h firstObject. [h isOld: oop] whileTrue: [(h isFree: oop) ifFalse: [fieldAddr: oop + oop lastOffset. [fieldAddr > oop] whileTrue: [fieldOop: (h at: fieldAddr). "Whether fieldOop points to a young object." (h isYoung: fieldOop) /\ fieldOop isSmallInt not ifTrue: [header: (h at: oop). "Forbidden: points to a young object without being a root." badRoot: True]. fieldAddr: fieldAddr - 4]]. oop: (h objectAfter: oop)]. badRoot ]!Bool. h@(ObjectHeap pointer) clearRootsTable "Clear the root bits of the current roots, and then empty the table. NOTE: this should only be done when the young object space is empty." [| oop!ObjectPointer | 0 below: h rootsCount do: [| :index | oop: (h rootTable at: index). oop pointer header isRoot: False. h rootTable at: index put: 0]. rootsCount: 0. ]. "Forwarding Blocks:" addStructureNamed: #ForwardingBlock. "The first word of the forwarding block is the new oop; the second word is the oop's original header. In the case of a forward become, a four-word block is used, with the third field being a backpointer to the old oop (for header fixup), and the fourth word is unused." ForwardingBlock addElementNamed: #newOop type: ObjectPointer. ForwardingBlock addElementNamed: #origHdr type: ObjectHeader. ForwardingBlock addElementNamed: #oldOop type: ObjectPointer. ForwardingBlock addElementNamed: #unused. "The Forwarding table linked list." ObjectHeap addElementNamed: #fwdTableNext type: ForwardingBlock pointer. ObjectHeap addElementNamed: #fwdTableLast type: ForwardingBlock pointer. h@(ObjectHeap pointer) fwdTableInitSize: blockSize "Set the limits for a table of two- or three-word forwarding blocks above the last used oop. The pointer fwdTableNext moves up to fwdTableLast. Used for compaction of memory and become:-ing objects. Answer the number of forwarding blocks available." [| blockSize | "Set memoryEnd to just after a minimum-sized free block." h setSizeOfFree: h freeBlock to: ObjectHeaderSize. h memoryEnd: h freeBlock + ObjectHeaderSize. "Make a fake free chunk at memoryEnd for use as a sentinel in memory scans." h setSizeOfFree: h memoryEnd to: ObjectHeaderSize. "use all memory free between freeBlock and memoryLimit for forwarding table" "NOTE: Forward blocks must be quadword aligned." h fwdTableNext: (h memoryEnd + ObjectHeaderSize + 2r111 bitAnd: 2 << 31 - (2 << 2)). "TODO: re-eval for Slate." h fwdTableLast: h memoryLimit - blockSize. "The last forwarding table entry." "Answer the number of forwarding blocks available, rounded down." h fwdTableLast - h fwdTableNext // blockSize ]!UnsignedLongInt. h@(ObjectHeap pointer) forwardingBlocksToCompactSized: blockSize "Answer an estimate of the number of forwarding blocks available for compaction." [| blockSize memoryEnd firstFwd!(ForwardingBlock pointer) lastFwd!(ForwardingBlock pointer) | memoryEnd: h freeBlock + ObjectHeaderSize. "Use all memory free between the freeBlock and memoryLimit for the forwarding table." "NOTE: forwarding blocks must be quad-word aligned." firstFwd: (memoryEnd + ObjectHeaderSize + 2r111 bitAnd: 2 << 31 - (2 << 2)). lastFwd: h memoryLimit - blockSize. "The last forwarding table entry." "Answer the number of forwarding blocks available, rounded down." lastFwd - firstFwd // blockSize ]!UnsignedLongInt. h@(ObjectHeap pointer) isValidForwardingBlock: addr "Whether the address is a valid forwarding block entry: past the end of main memory, below the next-pointer, and has clear tag-bits." [ addr > h memoryEnd /\ (addr <= h fwdTableNext) /\ ((addr bitAnd: 2r11) = 0) ]!Bool. h@(ObjectHeap pointer) validateForwardingBlock: addr "Raise an error if the given address is not a valid forwarding block entry." [ (h isValidForwardingBlock: addr) ifFalse: [error: 'Invalid forwarding block'] ]. h@(ObjectHeap pointer) nextForwardingBlockSized: blockSize "Answer the address of a 2/4-word forwarding block or Nil if no more entries are available." [ h fwdTableNext: h fwdTableNext + blockSize. h fwdTableNext <= h fwdTableLast ifTrue: [^ h fwdTableNext] ifFalse: [^ Nil] ]!Pointer. oop@ObjectPointer isForwarded "Answer whether the given object has a forwarding table entry during a compaction or become operation." [ oop isSmallInt not /\ (oop pointer header isMarked) ]!Bool inline export. hdr@ObjectHeader forwardingOop "This should return everything in the field but the mark bit and whatever header-type tag there is, for when the oop has been forwarded, and should give the location of the forwarding block where the new oop is stored. ASSUME: The oop actually isForwarded." [ ((hdr bitAnd: FreeMask) << 1)!(ForwardingBlock pointer) ]!(ForwardingBlock pointer) inline export. h@(ObjectHeap pointer) objectAfterWhileForwarding: oop [| oop!ObjectPointer header!ObjectHeader fwdBlock!(ForwardingBlock pointer) realHeader!ObjectHeader | header: oop pointer header. oop isForwarded ifFalse: [^ (h objectAfter: oop)]. "ASSUME: mark bit will not be set on a free chunk, so at this point, the oop is allocated and has a forwarding table entry." fwdBlock: header forwardingOop. h validateForwardingBlock: fwdBlock. realHeader: fwdBlock origHdr. oop + realHeader objectSize ]!ObjectPointer. h@(ObjectHeap pointer) makeRootWhileForwarding: oop [| oop!ObjectPointer header!ObjectHeader fwdBlock!(ForwardingBlock pointer) | header: oop pointer header. oop isForwarded ifTrue: [fwdBlock: header forwardingOop. h validateForwardingBlock: fwdBlock. h includeRoot: oop headerAt: fwdBlock + 4] ifFalse: [h includeRoot: oop headerAt: oop]. ]. h@(ObjectHeap pointer) lastOffsetWhileForwarding: oop "Find the offset of the last pointer in the object, even if the header word is in a forwarding block." [| oop!ObjectPointer header!ObjectHeader fwdBlock!(ForwardingBlock pointer) objSize | header: oop pointer header. oop isForwarded ifTrue: ["The oop is forwarded. Get the real header from the fwdTable." fwdBlock: header forwardingOop. h validateForwardingBlock: fwdBlock. header: (h at: fwdBlock + 4)]. header objectSize ]!UnsignedLongInt. h@(ObjectHeap pointer) updatePointersInRangeFrom: memStart to: memEnd "Update the pointers in the given memory range." [| oop!ObjectPointer | oop: memStart. [oop < memEnd] whileTrue: [(h isFree: oop) ifFalse: [h remapFieldsOf: oop]. oop: (h objectAfterWhileForwarding: oop)]. ]. h@(ObjectHeap pointer) updatePointersInRootObjectsFrom: memStart to: memEnd "Updates the pointers in root table objects." [| oop!ObjectPointer | 0 below: h rootsCount do: [| :index | oop: (h rootTable at: index). (h includes: oop) ifFalse: [h remapFieldsOf: oop]]. ]. h@(ObjectHeap pointer) pushRemappableOop: oop "Record the given object in the remap buffer." [| oop!ObjectPointer | h remapBuffer at: (h remapBufferCount: h remapBufferCount + 1) put: oop. ]. h@(ObjectHeap pointer) popRemappableOop "Pop and answer the possible remapped object from the remap buffer." [| oop!ObjectPointer | oop: (h remapBuffer at: h remapBufferCount). h remapBufferCount: h remapBufferCount - 1. oop ]!ObjectPointer. h@(ObjectHeap pointer) remap: oop "Map the given oop to its new value during a compaction or become: operation. If there is no forwarding table entry, answer the oop itself." [| oop!ObjectPointer fwdBlock!(ForwardingBlock pointer) header!ObjectHeader | header: oop pointer header. oop isForwarded ifTrue: [fwdBlock: header forwardingOop. h validateForwardingBlock: fwdBlock. ^ fwdBlock newOop]. oop ]!ObjectPointer. h@(ObjectHeap pointer) remapMapOf: oop "Update the map of the given object, if necessary, using its forwarding table entry." [| oop!ObjectPointer fwdBlock!(ForwardingBlock pointer) mapOop!ObjectPointer mapHeader!ObjectHeader newMapOop!ObjectPointer newMapHeader!ObjectHeader | mapOop: oop pointer map. mapOop isForwarded ifTrue: [fwdBlock: (h at: mapOop)!ObjectHeader forwardingOop. h validateForwardingBlock: fwdBlock. newMapOop: fwdBlock newOop. newMapHeader: (newMapOop bitOr: (mapHeader bitAnd: TypeMask)). h at: oop - 4 put: newMapHeader. "Ensure that become: into an old object's class makes it a root. This does nothing during either incremental or full compaction because oop will never be old." (h isOld: oop) /\ (h isYoung: newMapOop) ifTrue: [h makeRootWhileForwarding: oop]]. ]. h@(ObjectHeap pointer) remapFieldsOf: oop "Replace all forwarded pointers in this object with their new oops, using the forwarding table. NOTE: The given oop may be forwarded itself, which means that its real header is in its forwarding table entry." [| oop!ObjectPointer fieldIndex fieldOop!ObjectPointer fwdBlock!(ForwardingBlock pointer) newOop!ObjectPointer | fieldIndex: (h lastOffsetWhileForwarding: oop) - ObjectHeaderSize. [fieldIndex >= 0] whileTrue: [fieldOop: (oop pointer slotValueAt: fieldIndex). fieldOop isForwarded ifTrue: "Update this oop from its forwarding block." [fwdBlock: fieldOop pointer header forwardingOop. h validateForwardingBlock: fwdBlock. newOop: fwdBlock newOop. oop pointer slotValueAt: fieldIndex put: newOop. "Ensure that become: into an old object makes it a root. This does nothing during either full or incremental compaction because oop will never be old." (h isOld: oop) /\ (h isYoung: newOop) ifTrue: [h makeRootWhileForwarding: oop]]. fieldIndex: fieldIndex - 4]. h remapMapOf: oop. ]. h@(ObjectHeap pointer) mapPointersInObjectsFrom: memStart to: memEnd "Use the forwarding table to update the pointers of all non-free objects in the given range of memory. Also remap pointers in root objects which may contains pointers into the given memory range, and don't forget to flush the method cache based on the range." [ "h compilerMapHookFrom: memStart to: memEnd." "h mapInterpreterOops." "h flushMethodCacheFrom: memStart to: memEnd." h updatePointersInRootObjectsFrom: memStart to: memEnd. h updatePointersInRangeFrom: memStart to: memEnd. ]. h@(ObjectHeap pointer) initForwardingBlock: fwdBlock mapping: oop to: newOop withBackPtr: backFlag "Initialize the given forwarding block to map oop to newOop, and replace oop's header with a pointer to the fowarding block." "Details: The mark bit is used to indicate that an oop is forwarded. When an oop is forwarded, its header (minus the mark bit) contains the address of its forwarding block. (The forwarding block address is actually shifted right by one bit so that its top-most bit does not conflict with the header's mark bit; since fowarding blocks are stored on word boundaries, the low two bits of the address are always zero.)" [| fwdBlock!(ForwardingBlock pointer) oop!ObjectPointer newOop!ObjectPointer backFlag hdr!ObjectHeader | hdr: oop pointer header. fwdBlock = Nil ifTrue: [error: 'Ran out of forwarding blocks in the become operation.']. oop isForwarded ifTrue: [error: 'The object already has a forwarding table entry.']. fwdBlock newOop: newOop. fwdBlock origHdr: hdr. backFlag ifTrue: [fwdBlock oldOop: oop]. h at: oop put: (fwdBlock >> 1 bitOr: MarkBit). ]. "Compaction Range Boundaries:" ObjectHeap addElementNamed: #compStart type: ObjectPointer. ObjectHeap addElementNamed: #compEnd type: ObjectPointer. h@(ObjectHeap pointer) incCompactMakeFwd "Create and initialize forwarding blocks for all non-free objects following compStart. If the supply of forwarding blocks is exhausted, set compEnd to the first chunk above the area to be compacted; otherwise, set it to memoryEnd. Answer the number of words freed." [| wordsFreed oop!ObjectPointer fwdBlock!(ForwardingBlock pointer) newOop!ObjectPointer | wordsFreed: 0. oop: h compStart. [oop < h memoryEnd] whileTrue: [(h isFree: h compStart) ifTrue: [wordsFreed: wordsFreed + (h sizeOfFree: oop)] ifFalse: ["Create a forwarding block for the oop." fwdBlock: (h nextForwardingBlockSized: 8). fwdBlock = Nil "No forwarding blocks left; stop." ifTrue: [h compEnd: oop. ^ wordsFreed]. newOop: oop - wordsFreed. h initForwardingBlock: fwdBlock mapping: oop to: newOop withBackPtr: False]. oop: (h objectAfterWhileForwarding: oop)]. h compEnd: h memoryEnd. wordsFreed ]!UnsignedLongInt. h@(ObjectHeap pointer) incCompactMove: wordsFreed "Move all non-free objects between compStart and compEnd to their new locations, restoring their headers in the process. Create a new free block at the end of memory. Return the newly created free chunk." "Note: The free block used by the allocator always must be the last free block in memory. It may take several compaction passes to make all free space bubble up to the end of memory." [| oop!ObjectPointer next fwdBlock!(ForwardingBlock pointer) newOop!ObjectPointer wordsToMove firstWord lastWord wordsFreed newFreeChunk!ObjectPointer target | newOop: Nil. oop: h compStart. [oop < h compEnd] whileTrue: [next: h objectAfterWhileForwarding: oop. (h isFree: oop) ifFalse: ["A moving object; unwind its ForwardingBlock" fwdBlock: oop pointer header forwardingOop. h validateForwardingBlock: fwdBlock. newOop: fwdBlock newOop. oop pointer header: fwdBlock origHdr. "restore the original header" wordsToMove: oop - newOop. firstWord: oop. lastWord: oop + oop targetSize - ObjectHeaderSize. target: firstWord - wordsToMove. firstWord upTo: lastWord do: [| :w | h at: target put: (h at: w). target: target + 4]]. oop: next]. newOop = Nil ifTrue: ["no objects moved" oop: h compStart. (h isFree: oop) /\ ((h objectAfter: oop) = h compEnd) ifTrue: [newFreeChunk: oop] ifFalse: [newFreeChunk: h freeBlock]] ifFalse: ["initialize the newly freed memory chunk" "newOop is the last object moved; free chunk starts right after it" newFreeChunk: newOop + newOop targetSize. h setSizeOfFree: newFreeChunk to: wordsFreed]. (h objectAfter: newFreeChunk) = h compEnd ifFalse: [error: 'Couldn\'t create a free chunk after compaction']. (h objectAfter: newFreeChunk) = h memoryEnd ifTrue: [h initializeWithFirstFreeAt: newFreeChunk] "newFreeChunk is not at end of memory; re-install freeBlock" ifFalse: [h initializeWithFirstFreeAt: h freeBlock]. newFreeChunk ]!ObjectPointer. h@(ObjectHeap pointer) incCompactBody "Move objects to consolidate free space into one big chunk. Return the newly created free chunk." [| wordsFreed | h forwardingBlocksToCompactSized: 8. "Reserve memory for a forwarding table of 2-word-sized blocks." "Assign new oop locations, reverse the headers, and initialize forwarding blocks." wordsFreed: h incCompactMakeFwd. "Update pointers to point at the new oops." h mapPointersInObjectsFrom: h youngStart to: h memoryEnd. "Move the objects and restore their original headers. Return the new free chunk." h incCompactMove: wordsFreed ]!ObjectPointer. h@(ObjectHeap pointer) incrementalCompact "Move objects down to make one big free chunk. Compact the last N objects (where N = number of forwarding table entries) of the young object area. ASSUME: compStart was set during the sweep phase" [ h compStart = h freeBlock ifTrue: ["NOTE: Either the young space is already compact or there are enough forwarding table entries to do a one-pass incr. compaction." h initializeWithFirstFreeAt: h freeBlock] ifFalse: [h incCompactBody]. ]. h@(ObjectHeap pointer) fullCompact "Move all accessible objects down to leave one big free chunk at the end of memory. ASSUME: Incremental GC has just been done to maximize forwarding table space." [| numBlocks | "We don't need to move objects below the first chunk." h compStart: (h lowestFreeAfter: h memoryStart). "Memory is already compacted; only the free chunk is at the end." h compStart = h freeBlock ifTrue: [^ (h initializeWithFirstFreeAt: h freeBlock)]. (numBlocks: (h forwardingBlocksToCompactSized: 8)) < h totalObjectCount ifTrue: ["Try to grow the Heap to make a single-pass fullGC." h growBy: h totalObjectCount - numBlocks + 10000 * 8]. [h compStart < h freeBlock] whileTrue: "incCompactBody returns the next free chunk." [h compStart: h incCompactBody]. ]. h@(ObjectHeap pointer) runPreGCHooks [ ]. h@(ObjectHeap pointer) runPostGCHooks [ ]. h@(ObjectHeap pointer) ioMicroMSecs [0]. h@(ObjectHeap pointer) incrementalGC "Do a mark/sweep garbage collection of just the young object area of object memory (i.e., objects above youngStart), using the root table to identify objects containing pointers to young objects from the old object area." [| survivorCount startTime | "Check for root table overflow and handle it." h rootsCount >= RootTableSize ifTrue: [h statRootTableOverflows: statRootTableOverflows + 1. h fullGC]. h validateRoots. h runPreGCHooks. startTime: h ioMicroMSecs. h markPhase. survivorCount: h sweepPhase. h incrementalCompact. h allocationCount: 0. h allocationAmount: 0. h statIncrGCs: h statIncrGCs + 1. h statIncrGCMSecs: h statIncrGCMSecs + (h ioMicroMSecs - startTime). survivorCount > h tenuringThreshold \/ (h rootsCount >= RootTableSoftLimit) ifTrue: ["Raise the young space boundary if: (1) there are too many survivors: to limit the number of objects to process on the next GC. (2) the roots table could overflow soon: to limit the number of fullGC's caused by overflows in the near future." h statTenures: h statTenures + 1. h clearRootsTable. h youngStart: h freeBlock]. h runPostGCHooks. ] export. h@(ObjectHeap pointer) fullGC "Do a mark/sweep garbage collection of the entire ObjectHeap. Free inaccessible objects but do not move them." [| startTime | h runPreGCHooks. startTime: h ioMicroMSecs. h clearRootsTable. h youngStart: h memoryStart. h markPhase. h totalObjectCount: h sweepPhase. "The total number of survivors." h fullCompact. h allocationCount: 0. h allocationAmount: 0. h statFullGCs: h statFullGCs + 1. h statFullGCMSecs: h statFullGCMSecs + (h ioMicroMSecs - startTime). h youngStart: h freeBlock. h runPostGCHooks. ] export. "Mark/trace/sweep machinery." "The mark phase is based on a pointer reversing traversal, so that there's no need for a stack. The map, which is needed by the traversal, is in the word above the header. How do you know that you are returning from having marked a map? Parent pointer has 10 in low bits. Here are the states an object may be in, followed by what to do next in brackets []: Start Object: parentField is set, [obj: child]: obj is pointed at by a field in parent that is being traced now. obj is marked. [(parent goes up to the next field) field addr: obj. go to Upward] obj is pointed at by a field in parent that is being traced now. obj is unmarked. obj has no pointers. [put 10 into low bits of header. field addr: obj. go to Start Field (to process map word)] obj is pointed at by a field in parent that is being traced now. obj is unmarked. obj has pointers. [put 10 into low bits of header. point to last field. go to Start Field] Start Field: Field ends in 10. It is the header. => [Set low bits to correct value. (have parent pointer) go to Upward] Field ends in 10. It is the header. => [child: word above header. low bits of child: 01. map word: parentField. parentField: loc of map word. go to Start Obj] Field is Integer. => [point one word up, go to Start Field] Field is oop. => [child: field. field: parentField. parentField: loc of field. go to Start Obj] Upward [restore low bits of header (at field addr)]: parentField is 3. (bits 11, int 1). => [done!] parentField ends in 00. => [child: field addr. field addr: parentField. parentField: field addr contents. field addr contents: child (addr of prev object. its oop). field addr - 4. go to Start Field] parentField ends in 01. Were tracing the map. => [child: field addr. field addr: parentField (loc of map word). parentField: field addr contents. field addr contents: child (addr of prev object. its oop). field addr + 4 (header). go to Upward]. " "States:" addConstantNamed: #StartField valued: 0. addConstantNamed: #StartObj valued: 1. addConstantNamed: #Upward valued: 2. addConstantNamed: #Done valued: 3. "Mark-sweep cursors." ObjectHeap addElementNamed: #child type: ObjectPointer. "The object being examined." ObjectHeap addElementNamed: #field type: ObjectPointer pointer. "The next field of the child to examine." ObjectHeap addElementNamed: #parentField type: Pointer. "The field where the child was stored in its referencing object." addConstantNamed: #GCTopMarker valued: 2r11. addConstantNamed: #GCStartField valued: 2r1. h@(ObjectHeap pointer) startObj "Start tracing from the child object and answer the next action. The object may be anywhere in the middle of being swept itself." [| oop!ObjectPointer obj!(Object pointer) lastFieldOffset | oop: h child. oop < h youngStartLocal "Old object; skip it." ifTrue: [field: oop. ^ Upward]. obj: oop pointer. obj header isMarked ifTrue: "Already marked; skip it." [h field: oop. ^ Upward] ifFalse: ["TODO: extend to handle weak slots here." lastFieldOffset: oop pointer lastOffset. obj mark. h field: obj + lastFieldOffset. ^ StartField]. ]!UnsignedLongInt inline. h@(ObjectHeap pointer) startField "Examine and possibly trace the next field of the object being traced; note that this is the mark/sweep variant where the parent backpointer is stored in the slot followed to avoid recursion depth." [ h child: h field load. (h isSmallInt: h child) ifTrue: "The field has a SmallInt. Skip it." [h field: h field - 4. ^ StartField]. h child isObject ifTrue: "Normal object pointer. Follow it." [h field store: h parentField. h parentField: h field. ^ StartObj]. "TODO: Handle headers here." ]!UnsignedLongInt inline. h@(ObjectHeap pointer) upward "Return from marking an object below. Incoming: field = oop we just worked on, needs to be put away parentField = where to put it in our object." [| header!ObjectHeader | (h parentField bitAnd: 1) = 1 ifTrue: [h parentField = GCTopMarker ifTrue: "Top of the chain." [^ Done] ifFalse: [h child: h field. h field: h parentField - 4. h parentField: h field load. header: ((h field + 4) load)!ObjectHeader. h field store: h child. h field: h field + 4. ^ Upward]] ifFalse: "Normal" [h child: h field. h field: h parentField. h parentField: h field load. h field store: h child. h field: h field - 4. ^ StartField]. ]!UnsignedLongInt inline. h@(ObjectHeap pointer) markAndTraceFrom: oop "Mark all objects reachable from the given one. Trace from it even if it is old. Don't trace if already marked. Mark an object only if it is young." [| oop!ObjectPointer obj!(Object pointer) header!ObjectHeader lastFieldOffset action | obj: oop pointer. header: obj header. header isMarked ifTrue: [^ 0]. "Record the tracing status in the object's header." header: ((header bitAnd: 16rCFFF) bitOr: 2r10). "TODO: use the real bitmask." (h isYoung: oop) ifTrue: [obj mark]. "Mark it only if it's young." obj header: header. "Initialize the tracer state machine." h parentField: GCTopMarker. h child: oop. lastFieldOffset: oop lastOffset. h field: oop + lastFieldOffset. action: StartField. h youngStartLocal: h youngStart. "Run the tracer until objects reachable from this oop are marked." [action = Done] whileFalse: [action = StartField ifTrue: [action: h startField]. action = StartObj ifTrue: [action: h startObj]. action = Upward ifTrue: [action: h upward]]. ]!UnsignedLongInt. h@(ObjectHeap pointer) markPhase "The mark phase: set the mark bits of all reachable objects. Free chunks are untouched. ASSUME: All non-free objects are initially unmarked. Root objects were unmarked when they were made roots; they must remain so." [| oop!ObjectPointer | "Clear the recycled context lists." "h freeContexts: h NilContext. TODO: Interp" "h freeLargeContexts: h NilContext. TODO: Interp" "Trace the interpreter's objects, including the active stack and special objects array." "h markAndTraceInterpreterOops. TODO: Interp" "Trace the roots." 0 below: h rootsCount do: [| :index | oop: (h rootTable at: index). h markAndTraceFrom: oop]. ]. h@(ObjectHeap pointer) sweepPhase "Sweep memory from youngStart through the end of memory. Free all of the inaccessible objects and coalesce the adjacent free chunks. Clear the mark bits of accessible objects. Compute the starting point for the first pass of incremental compaction (compStart). Return the number of surviving objects." "DETAILS: Each time a non-free object is encountered, decrement the number of available forward table entries. If all entries are spoken for (i.e., entriesAvailable reaches zero), set compStart to the last free chunk before that object or, if there is no free chunk before the given object, the first free chunk after it. Thus, at the end of the sweep phase, compStart through compEnd spans the highest collection of non-free objects that can be accommodated by the forwarding table. This information is used by the first pass of incremental compaction to ensure that space is initially freed at the end of memory. Note that there should always be at least one free chunk (the one at the end of the heap)." [| availableEntries survivors freeChunk firstFree oop!ObjectPointer oopHeader!ObjectHeader oopSize freeChunkSize memoryEndLocal | availableEntries: (h fwdTableInitSize: 2). survivors: 0. freeChunk: Nil. firstFree: Nil. memoryEndLocal: h memoryEnd. oop: h youngStart. [oop < memoryEndLocal] whileTrue: [oopHeader: oop pointer header. oopSize: oopHeader objectSize. oopHeader isMarked ifTrue: "The object is marked. Clear the mark and possibly adjust where compaction starts." [oop pointer unmark. "TODO: Finalization support for weak references here." availableEntries > 0 ifTrue: [availableEntries: availableEntries - 1] ifFalse: [firstFree: freeChunk]. "Start compaction at the last free chunk before this object." freeChunk ifNotNil: "Record the size of the last free chunk." [h at: freeChunk put: (freeChunkSize bitAnd: NonTagMask). freeChunk: Nil]. survivors: survivors + 1] ifFalse: "The object is not marked. Free it." ["TODO: Finalization support for weak references here." freeChunk ifNil: ["Start a new free chunk." freeChunk: oop - ObjectHeaderSize. "The free chunk may start 1 or 2 words before the oop." freeChunkSize: oopSize + (oop - freeChunk). firstFree ifNil: [firstFree: freeChunk]] ifNotNil: ["Enlarge the current free chunk to include this oop." freeChunkSize: freeChunkSize + oopSize + ObjectHeaderSize]]. oop: oop + oopSize]. freeChunk ifNotNil: "Record the size of the final free chunk." [h at: freeChunk put: ((freeChunkSize bitAnd: FreeMask) bitOr: WeakMask)]. oop = h memoryEnd ifTrue: [error: 'The sweep failed to find the exact end of memory.']. firstFree ifNil: [error: 'Expected to find at least one free object.'] ifNotNil: [h compStart: firstFree]. survivors ]. "Utilities - Code relying on GC details but generally-useful." h@(ObjectHeap pointer) hasSufficientSpaceAfterGC: minFree "Answer whether there is enough free space after doing a GC. If not, signal that space is low." [| growSize | h incrementalGC. (h sizeOfFreeBlock)!UnsignedLongInt > minFree!UnsignedLongInt ifTrue: [h signalLowSpace ifTrue: [^ False]. h fullGC. "Try harder." (h sizeOfFreeBlock)!UnsignedLongInt >= (minFree!UnsignedLongInt + 15000) ifTrue: [^ True]. growSize: minFree - h sizeOfFreeBlock + h growthHeadroom. h growBy: growSize. (h sizeOfFreeBlock)!UnsignedLongInt >= (minFree!UnsignedLongInt + 15000) ifTrue: [^ True]. ^ False]. True ]!Bool export. h@(ObjectHeap pointer) hasSufficientSpaceToAllocate: words "Answer whether there is enough space to allocate the given number of words, perhaps after performing a GC." [| minFree | minFree: h lowSpaceThreshold + words + ObjectHeaderSize. ((h sizeOfFreeBlock)!UnsignedLongInt >= minFree!UnsignedLongInt) \/ (h hasSufficientSpaceAfterGC: minFree) ]!Bool. "Object Creation:" h@(ObjectHeap pointer) allocateChunkSized: wordSize "Allocate a chunk of the given size. Sender must be sure that the requested size includes enough space for the header word(s). Details: To limit the time per incremental GC, do one every so many allocations." [| enoughSpace newFreeSize newChunk | "Perform an incremental GC if necessary to keep pauses short." h allocationCount >= h allocationsBetweenCollections \/ (h allocationAmount >= h maxAllocationBetweenCollections) ifTrue: [h incrementalGC]. enoughSpace: (h hasSufficientSpaceToAllocate: wordSize). enoughSpace ifFalse: [h signalLowSpace: True. h lowSpaceThreshold: 0. "disable additional interrupts until lowSpaceThreshold is reset by the image." " h interruptCheckCounter: 0"]. (h sizeOfFreeBlock)!UnsignedLongInt < (ObjectHeaderSize + wordSize)!UnsignedLongInt ifTrue: [error: 'Out of memory']. newFreeSize: h sizeOfFreeBlock - wordSize. newChunk: h freeBlock. h freeBlock: h freeBlock + wordSize. "ASSUME: the client will initialize object headers of the free chunk. otherwise the following is required:" "h setSizeOfFree: newChunk to: wordSize." h setSizeOfFree: h freeBlock to: newFreeSize. h allocationCount: h allocationCount + 1. h allocationAmount: h allocationAmount + wordSize. newChunk!(Object pointer) ]!(Object pointer) export. h@(ObjectHeap pointer) clone: oop "Answer a shallow copy of the given object. ASSUME: Oop is a real object, not a small integer." [| oop!ObjectPointer newChunk!ObjectPointer words remappedOop!ObjectPointer fromIndex toIndex lastFrom newOop!ObjectPointer | words: oop targetSize. "Allocate space for the clone. Remap the oop in case of a GC." h pushRemappableOop: oop. newChunk: (h allocateChunkSized: words). remappedOop: h popRemappableOop. "Copy the words from old to new." toIndex: newChunk - 4. fromIndex: remappedOop - 4. lastFrom: fromIndex + words. [fromIndex < lastFrom] whileTrue: [h at: (toIndex: toIndex + 4) put: (h at: (fromIndex: fromIndex + 4))]. newChunk pointer unmark. newChunk pointer header idHash. newChunk ]!ObjectPointer export. "become:-related machinery:" h@(ObjectHeap pointer) allAreYoungIn: array1 and: array2 "Answer if all the Oops in both arrays, and the arrays themselves, are in the young object space." [| array1!ObjectPointer array2!ObjectPointer fieldOffset | (h isOld: array1) \/ (h isOld: array2) ifTrue: [^ False]. fieldOffset: array1 lastOffset. [fieldOffset >= ObjectHeaderSize] whileTrue: [(h isOld: ((h at: array1 + fieldOffset) max: (h at: array2 + fieldOffset))) ifTrue: [^ False]. fieldOffset: fieldOffset - 4]. True ]!Bool.