VM Maker: VMMaker.oscog-eem.2251.mcz

 
Eliot Miranda uploaded a new version of VMMaker to project VM Maker:
http://source.squeak.org/VMMaker/VMMaker.oscog-eem.2251.mcz

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

Name: VMMaker.oscog-eem.2251
Author: eem
Time: 7 July 2017, 12:55:32.357331 pm
UUID: d951ed1a-ef1a-4934-b379-3bef3773f2b3
Ancestors: VMMaker.oscog-eem.2250

Spur:
Round the space estimate when a new segment is used for planning compaction to avoid an assert fail.

Fix bad slip in computing objectsReachableFromRoots: (the wrong object was being marked when pushing unmarked objects onto the objStack), and rewrite to avoid growing the markStack unnecessarily.  Fix an assert fail in adding to the mark stack by handling totalFreeOldSpace correctly (and comment other callers of allocateLargestFreeChunk).

Refactor use of marked bit to identify heap objects copied into the segment into isCopiedIntoSegment: & markAsCopiedIntoSegment:.

Make sure unsigned comparisons are used for several address/oop comparisons in the segment code.

Add support for doing an image segment save and/or load in a clone (which was key in debugging the slip in objectsReachableFromRoots:).

Add some debugging routines: forwardersIn:, indexOf:in:.

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

Item was changed:
  ----- Method: Spur32BitMMLECoSimulator>>storeImageSegmentInto:outPointers:roots: (in category 'image segment in/out') -----
  storeImageSegmentInto: segmentWordArray outPointers: outPointerArray roots: arrayOfRoots
  self leakCheckImageSegments ifTrue:
+ [parent ifNil:
+ [| result |
+ self halt.
+ result := coInterpreter cloneSimulation objectMemory storeImageSegmentInto: segmentWordArray outPointers: outPointerArray roots: arrayOfRoots.
+ Smalltalk garbageCollect]].
- [self halt].
  ^super storeImageSegmentInto: segmentWordArray outPointers: outPointerArray roots: arrayOfRoots!

Item was changed:
  ----- Method: Spur32BitMMLESimulator>>storeImageSegmentInto:outPointers:roots: (in category 'image segment in/out') -----
  storeImageSegmentInto: segmentWordArray outPointers: outPointerArray roots: arrayOfRoots
  self leakCheckImageSegments ifTrue:
+ [parent ifNil:
+ [| result |
+ self halt.
+ result := coInterpreter cloneSimulation objectMemory storeImageSegmentInto: segmentWordArray outPointers: outPointerArray roots: arrayOfRoots.
+ Smalltalk garbageCollect]].
- [self halt].
  ^super storeImageSegmentInto: segmentWordArray outPointers: outPointerArray roots: arrayOfRoots!

Item was changed:
  ----- Method: Spur64BitMMLECoSimulator>>storeImageSegmentInto:outPointers:roots: (in category 'image segment in/out') -----
  storeImageSegmentInto: segmentWordArray outPointers: outPointerArray roots: arrayOfRoots
  self leakCheckImageSegments ifTrue:
+ [parent ifNil:
+ [| result |
+ self halt.
+ result := coInterpreter cloneSimulation objectMemory storeImageSegmentInto: segmentWordArray outPointers: outPointerArray roots: arrayOfRoots.
+ Smalltalk garbageCollect]].
- [self halt].
  ^super storeImageSegmentInto: segmentWordArray outPointers: outPointerArray roots: arrayOfRoots!

Item was changed:
  ----- Method: Spur64BitMMLESimulator>>storeImageSegmentInto:outPointers:roots: (in category 'image segment in/out') -----
  storeImageSegmentInto: segmentWordArray outPointers: outPointerArray roots: arrayOfRoots
  self leakCheckImageSegments ifTrue:
+ [parent ifNil:
+ [| result |
+ self halt.
+ result := coInterpreter cloneSimulation objectMemory storeImageSegmentInto: segmentWordArray outPointers: outPointerArray roots: arrayOfRoots.
+ Smalltalk garbageCollect]].
- [self halt].
  ^super storeImageSegmentInto: segmentWordArray outPointers: outPointerArray roots: arrayOfRoots!

Item was changed:
  ----- Method: SpurImageSegmentTests>>testSaveHashedCollectionAndAllSubclasses (in category 'tests') -----
  testSaveHashedCollectionAndAllSubclasses
  SimulatorHarnessForTests new
  withExecutableInterpreter: self initializedVM
  do: [:vm :harness| | error objects |
  CheckForLeaks == true ifTrue: "CheckForLeaks := self confirm: 'Check for leaks?'"
  [vm objectMemory setCheckForLeaks: (vm objectMemory class bindingOf: #GCModeImageSegment) value].
  error := harness findSymbol: #error.
  self deny: error isNil.
  objects := harness
  interpreter: vm
  object: (harness findClassNamed: 'Compiler')
  perform: (harness findSymbol: #evaluate:)
  withArguments: {vm objectMemory stringForCString:
+ '[| seg out roots result |
- '[| seg out result |
  seg := WordArray new: 1024 * 1024.
  out := Array new: 512.
  roots := HashedCollection withAllSubclasses asArray.
  roots := roots, (roots collect: [:ea| ea class]).
  (thisContext isPrimFailToken: (nil tryPrimitive: 98 withArgs: { roots. seg. out })) ifTrue:
  [^#error].
  result := { seg. out }.
  (thisContext isPrimFailToken: (nil tryPrimitive: 99 withArgs: result)) ifTrue:
  [^#error].
  result]
  on: Error
  do: [:ex| ^#error]'}.
  self deny: objects = error]!

Item was changed:
  ----- Method: SpurImageSegmentTests>>testSaveHashedCollectionSubclasses (in category 'tests') -----
  testSaveHashedCollectionSubclasses
  SimulatorHarnessForTests new
  withExecutableInterpreter: self initializedVM
  do: [:vm :harness| | error objects |
  CheckForLeaks == true ifTrue: "CheckForLeaks := self confirm: 'Check for leaks?'"
  [vm objectMemory setCheckForLeaks: (vm objectMemory class bindingOf: #GCModeImageSegment) value].
  error := harness findSymbol: #error.
  self deny: error isNil.
  objects := harness
  interpreter: vm
  object: (harness findClassNamed: 'Compiler')
  perform: (harness findSymbol: #evaluate:)
  withArguments: {vm objectMemory stringForCString:
+ '[| seg out roots result |
- '[| seg out result |
  seg := WordArray new: 1024 * 1024.
  out := Array new: 256.
  roots := HashedCollection subclasses asArray.
  roots := roots, (roots collect: [:ea| ea class]).
  (thisContext isPrimFailToken: (nil tryPrimitive: 98 withArgs: { roots. seg. out })) ifTrue:
  [^#error].
  result := { seg. out }.
  (thisContext isPrimFailToken: (nil tryPrimitive: 99 withArgs: result)) ifTrue:
  [^#error].
  result]
  on: Error
  do: [:ex| ^#error]'}.
  self deny: objects = error]!

Item was changed:
  ----- Method: SpurMemoryManager>>allInstancesOf: (in category 'primitive support') -----
  allInstancesOf: aClass
  "Attempt to answer an array of all objects, excluding those that may
  be garbage collected as a side effect of allocating the result array.
  If no memory is available answer the number of instances as a SmallInteger.
  Since objects are at least 16 bytes big, and the largest SmallInteger covers
  1/4 of the address space, the count can never overflow."
  | classIndex freeChunk ptr start limit count bytes |
  classIndex := self rawHashBitsOf: aClass.
  classIndex = 0 ifTrue:
  [freeChunk := self allocateSlots: 0 format: self arrayFormat classIndex: ClassArrayCompactIndex.
  ^freeChunk].
  MarkObjectsForEnumerationPrimitives ifTrue:
  [self markObjects: true]. "may not want to revive objects unnecessarily; but marking is sloooow."
+ freeChunk := self allocateLargestFreeChunk. "N.B. Does /not/ update totalFreeOldSpace"
- freeChunk := self allocateLargestFreeChunk.
  start := freeChunk + self baseHeaderSize.
  limit := self addressAfter: freeChunk.
  (self isClassAtUniqueIndex: aClass)
  ifTrue:
  [self uniqueIndex: classIndex allInstancesInto: start limit: limit resultsInto: [:c :p| count := c. ptr := p]]
  ifFalse:
  [self ambiguousClass: aClass allInstancesInto: start limit: limit resultsInto: [:c :p| count := c. ptr := p]].
  self assert: (self isEmptyObjStack: markStack).
  MarkObjectsForEnumerationPrimitives
  ifTrue:
  [self assert: self allObjectsUnmarked.
  self emptyObjStack: weaklingStack]
  ifFalse:
  [self assert: (self isEmptyObjStack: weaklingStack)].
  (count > (ptr - start / self bytesPerOop) "not enough room"
  or: [limit ~= ptr and: [limit - ptr <= self allocationUnit]]) ifTrue: "can't split a single word"
  [self freeObject: freeChunk.
  ^self integerObjectOf: count].
  count < self numSlotsMask ifTrue:
  [| smallObj |
  smallObj := self allocateSlots: count format: self arrayFormat classIndex: ClassArrayCompactIndex.
  0 to: count - 1 do:
  [:i|
  self storePointerUnchecked: i ofObject: smallObj withValue: (self fetchPointer: i ofFreeChunk: freeChunk)].
  self freeChunkWithBytes: (self bytesInObject: freeChunk) at: (self startOfObject: freeChunk).
  self beRootIfOld: smallObj.
  self checkFreeSpace: GCModeFull.
  ^smallObj].
  bytes := self largeObjectBytesForSlots: count.
  start := self startOfObject: freeChunk.
  self freeChunkWithBytes: limit - start - bytes at: start + bytes.
  totalFreeOldSpace := totalFreeOldSpace - bytes.
  self rawOverflowSlotsOf: freeChunk put: count.
  self set: freeChunk classIndexTo: ClassArrayCompactIndex formatTo: self arrayFormat.
  self possibleRootStoreInto: freeChunk.
  self checkFreeSpace: GCModeFull.
  self runLeakCheckerFor: GCModeFull.
  ^freeChunk
 
  !

Item was changed:
  ----- Method: SpurMemoryManager>>allObjects (in category 'primitive support') -----
  allObjects
  "Attempt to answer an array of all objects, excluding those that may
  be garbage collected as a side effect of allocating the result array.
  If no memory is available answer the number of objects as a SmallInteger.
  Since objects are at least 16 bytes big, and the largest SmallInteger covers
  1/4 of the address space, the count can never overflow."
  | freeChunk ptr start limit count bytes |
  MarkObjectsForEnumerationPrimitives ifTrue:
  [self markObjects: true]. "may not want to revive objects unnecessarily; but marking is sloooow."
+ freeChunk := self allocateLargestFreeChunk. "N.B. Does /not/ update totalFreeOldSpace"
- freeChunk := self allocateLargestFreeChunk.
  ptr := start := freeChunk + self baseHeaderSize.
  limit := self addressAfter: freeChunk.
  count := 0.
  self allHeapEntitiesDo:
  [:obj| "continue enumerating even if no room so as to unmark all objects."
  (MarkObjectsForEnumerationPrimitives
  ifTrue: [self isMarked: obj]
  ifFalse: [true]) ifTrue:
  [(self isNormalObject: obj)
  ifTrue:
  [MarkObjectsForEnumerationPrimitives ifTrue:
  [self setIsMarkedOf: obj to: false].
  count := count + 1.
  ptr < limit ifTrue:
  [self longAt: ptr put: obj.
  ptr := ptr + self bytesPerOop]]
  ifFalse:
  [MarkObjectsForEnumerationPrimitives ifTrue:
  [(self isSegmentBridge: obj) ifFalse:
  [self setIsMarkedOf: obj to: false]]]]].
  self assert: (self isEmptyObjStack: markStack).
  MarkObjectsForEnumerationPrimitives
  ifTrue:
  [self assert: self allObjectsUnmarked.
  self emptyObjStack: weaklingStack]
  ifFalse:
  [self assert: (self isEmptyObjStack: weaklingStack)].
  self assert: count >= self numSlotsMask.
  (count > (ptr - start / self bytesPerOop) "not enough room"
  or: [limit ~= ptr and: [limit - ptr <= self allocationUnit]]) ifTrue: "can't split a single word"
  [self freeChunkWithBytes: (self bytesInObject: freeChunk) at: (self startOfObject: freeChunk).
  self checkFreeSpace: GCModeFull.
  ^self integerObjectOf: count].
  bytes := self largeObjectBytesForSlots: count.
  start := self startOfObject: freeChunk.
  self freeChunkWithBytes: limit - start - bytes at: start + bytes.
  totalFreeOldSpace := totalFreeOldSpace - bytes.
  self rawOverflowSlotsOf: freeChunk put: count.
  self set: freeChunk classIndexTo: ClassArrayCompactIndex formatTo: self arrayFormat.
  self possibleRootStoreInto: freeChunk.
  self checkFreeSpace: GCModeFull.
  self runLeakCheckerFor: GCModeFull.
  ^freeChunk
 
  !

Item was changed:
  ----- Method: SpurMemoryManager>>assignClassIndicesAndPinFrom:to:outPointers:filling: (in category 'image segment in/out') -----
  assignClassIndicesAndPinFrom: segmentStart to: segmentLimit outPointers: outPointerArray filling: loadedObjectsArray
  "This is part of loadImageSegmentFrom:outPointers:.
  Make a final pass, assigning the real class indices and/or pinning pinned objects."
  | fillIdx objOop |
  objOop := self objectStartingAt: segmentStart.
  fillIdx := 0.
+ [self oop: objOop isLessThan: segmentLimit] whileTrue:
- [objOop < segmentLimit] whileTrue:
  [| classRef classOop classIndex |
  self storePointerUnchecked: fillIdx ofObject: loadedObjectsArray withValue: objOop.
  fillIdx := fillIdx + 1.
  "In the segment, class indices are offset indexes into the segment data,
   or into outPointers.  See mapOopsFrom:to:outPointers:outHashes: and
   newOutPointer:at:in:hashes:."
  classRef := self classIndexOf: objOop.
  classOop := (classRef anyMask: TopHashBit)
  ifTrue: [self fetchPointer: classRef - TopHashBit ofObject: outPointerArray]
  ifFalse: [classRef - self firstClassIndexPun * self allocationUnit + segmentStart].
  classIndex := self rawHashBitsOf: classOop.
  self assert: (classIndex > self lastClassIndexPun
   and: [(self classOrNilAtIndex: classIndex) = classOop]).
  self setClassIndexOf: objOop to: classIndex.
  ((self isInNewSpace: objOop)
   and: [self isPinned: objOop]) ifTrue:
  [| oldClone |
  oldClone := self cloneInOldSpaceForPinning: objOop.
  oldClone ~= 0 ifTrue:
  [self setIsPinnedOf: oldClone to: true.
  self forward: objOop to: oldClone]].
  objOop := self objectAfter: objOop limit: segmentLimit]!

Item was changed:
  ----- Method: SpurMemoryManager>>copyObj:toAddr:startAt:stopAt:savedFirstFields:index: (in category 'image segment in/out') -----
  copyObj: objOop toAddr: segAddr startAt: segStart stopAt: endSeg savedFirstFields: savedFirstFields index: i
  "This is part of storeImageSegmentInto:outPointers:roots:.
  Copy objOop into the segment beginning at segAddr, and forward it to the copy,
  saving its first field in savedFirstField, and setting its marked bit to indicate it has
  been copied.  If it is a class in the class table, set the copy's hash to 0 for reassignment
  on load, and mark it as a class by setting its isRemembered bit.
  Answer the next segmentAddr if successful.  Answer an appropriate error code if not"
 
  "Copy the object..."
  | bodySize copy hash |
  <inline: false>
+ self deny: (self isCopiedIntoSegment: objOop).
  bodySize := self bytesInObject: objOop.
  (self oop: segAddr + bodySize isGreaterThanOrEqualTo: endSeg) ifTrue:
  [^PrimErrWritePastObject halt].
  self mem: segAddr asVoidPointer cp: (self startOfObject: objOop) asVoidPointer y: bodySize.
  copy := self objectStartingAt: segAddr.
 
  "Clear remembered, mark bits of all headers copied into the segment (except classes)"
  self
  setIsRememberedOf: copy to: false;
  setIsMarkedOf: copy to: false.
 
  "Make any objects with hidden dynamic state (contexts, methods) look like normal objects."
  self ifAProxy: objOop updateCopy: copy.
 
  "If the object is a class, zero its identityHash (which is its classIndex) and set its
  isRemembered bit.  It will be assigned a new hash and entered into the table on load."
  hash := self rawHashBitsOf: objOop.
  (hash > self lastClassIndexPun and: [(self classOrNilAtIndex: hash) = objOop]) ifTrue:
  [self setHashBitsOf: copy to: 0.
  self setIsRememberedOf: copy to: true].
 
  "Now forward the object to its copy in the segment."
  self storePointerUnchecked: i ofObject: savedFirstFields withValue: (self fetchPointer: 0 ofObject: objOop);
  storePointerUnchecked: 0 ofObject: objOop withValue: copy;
+ markAsCopiedIntoSegment: objOop.
- setIsMarkedOf: objOop to: true.
 
  "Answer the new end of segment"
  ^segAddr + bodySize!

Item was changed:
  ----- Method: SpurMemoryManager>>enterClassesIntoClassTableFrom:to: (in category 'image segment in/out') -----
  enterClassesIntoClassTableFrom: segmentStart to: segmentLimit
    "This is part of loadImageSegmentFrom:outPointers:.
  Scan for classes contained in the segment, entering them into the class table,
  and clearing their isRemembered: bit. Classes are at the front, after the root
  array and have the remembered bit set. If the attempt succeeds, answer 0,
  otherwise remove all entered entries and answer an error code."
  | objOop errorCode|
  objOop := self objectAfter: (self objectStartingAt: segmentStart).
+ [(self oop: objOop isLessThan: segmentLimit)
- [objOop < segmentLimit
  and: [self isRemembered: objOop]] whileTrue:
  [self setIsRememberedOf: objOop to: false.
  (errorCode := self enterIntoClassTable: objOop) ~= 0 ifTrue:
  [| oop |
  oop := objOop.
  objOop := self objectAfter: (self objectStartingAt: segmentStart).
+ [self oop: objOop isLessThan: oop] whileTrue:
- [objOop < oop] whileTrue:
  [self expungeFromClassTable: objOop.
  objOop := self objectAfter: objOop limit: segmentLimit].
  ^errorCode].
  objOop := self objectAfter: objOop limit: segmentLimit].
  ^0!

Item was added:
+ ----- Method: SpurMemoryManager>>forwardersIn: (in category 'debug support') -----
+ forwardersIn: anObject
+ "Answer if anObject is itself forwarded, or is a pointer object containing any references to forwarded objects."
+ (self isForwarded: anObject) ifTrue:
+ [^true].
+ 0 to: (self numPointerSlotsOf: anObject) - 1 do:
+ [:i| | oop |
+ oop := self fetchPointer: i ofMaybeForwardedObject: anObject.
+ ((self isNonImmediate: oop)
+  and: [self isForwarded: oop]) ifTrue:
+ [^true]].
+ ^false!

Item was added:
+ ----- Method: SpurMemoryManager>>indexOf:in: (in category 'debug support') -----
+ indexOf: anElement in: anObject
+ <api>
+ | fmt numSlots |
+ fmt := self formatOf: anObject.
+
+ fmt <= self lastPointerFormat ifTrue:
+ [numSlots := self numSlotsOf: anObject.
+ 0 to: numSlots do:
+ [:i| anElement = (self fetchPointer: i ofMaybeForwardedObject: anObject) ifTrue: [^i]].
+ -1].
+
+ fmt >= self firstByteFormat ifTrue:
+ [fmt >= self firstCompiledMethodFormat ifTrue:
+ [^self primitiveFailFor: PrimErrUnsupported].
+ numSlots := self numBytesOfBytes: anObject.
+ 0 to: numSlots do:
+ [:i| (self fetchByte: i ofObject: anObject) ifTrue: [^i]].
+ -1].
+
+ fmt >= self firstShortFormat ifTrue:
+ [numSlots := self num16BitUnitsOf: anObject.
+ 0 to: numSlots do:
+ [:i| anElement = (self fetchUnsignedShort16: i ofObject: anObject) ifTrue: [^i]].
+ -1].
+
+ fmt = self sixtyFourBitIndexableFormat ifTrue:
+ [numSlots := self num64BitUnitsOf: anObject.
+ 0 to: numSlots do:
+ [:i| anElement = (self fetchLong64: i ofObject: anObject) ifTrue: [^i]].
+ -1].
+
+ fmt >= self firstLongFormat ifTrue:
+ [numSlots := self num32BitUnitsOf: anObject.
+ 0 to: numSlots do:
+ [:i| anElement = (self fetchLong32: i ofObject: anObject) ifTrue: [^i]].
+ -1].
+
+ ^-1!

Item was added:
+ ----- Method: SpurMemoryManager>>isCopiedIntoSegment: (in category 'image segment in/out') -----
+ isCopiedIntoSegment: anObjectInTheHeap
+ <inline: true>
+ ^self isMarked: anObjectInTheHeap!

Item was changed:
  ----- Method: SpurMemoryManager>>mapOopsAndValidateClassRefsFrom:to:outPointers: (in category 'image segment in/out') -----
  mapOopsAndValidateClassRefsFrom: segmentStart to: segmentLimit outPointers: outPointerArray
  "This is part of loadImageSegmentFrom:outPointers:.
  Scan through mapping oops and validating class references.  Defer
  entering any class objects into the class table and/or pinning objects
  until the second pass in assignClassIndicesAndPinFrom:to:outPointers:."
  | numOutPointers numSegObjs objOop |
  numOutPointers := self numSlotsOf: outPointerArray.
  numSegObjs := 0.
  objOop := self objectStartingAt: segmentStart.
+ [self oop: objOop isLessThan: segmentLimit] whileTrue:
- [objOop < segmentLimit] whileTrue:
  [| classIndex hash oop mappedOop |
  numSegObjs := numSegObjs + 1.
+ "No object in the segment should be marked.  If is is something is wrong."
  (self isMarked: objOop) ifTrue:
  [^PrimErrInappropriate].
  classIndex := self classIndexOf: objOop.
  "validate the class ref, but don't update it until any internal classes have been added to the class table."
  (classIndex anyMask: TopHashBit)
  ifTrue:
  [classIndex := classIndex - TopHashBit.
  classIndex >= numOutPointers ifTrue:
  [^PrimErrBadIndex halt].
  mappedOop := self fetchPointer: classIndex ofObject: outPointerArray.
  hash := self rawHashBitsOf: mappedOop.
  (hash > self lastClassIndexPun and: [(self classOrNilAtIndex: hash) = mappedOop]) ifFalse:
  [^PrimErrInappropriate halt]]
  ifFalse: "The class is contained within the segment."
  [(oop := classIndex - self firstClassIndexPun * self allocationUnit + segmentStart) >= segmentLimit ifTrue:
  [^PrimErrBadIndex halt].
  (self rawHashBitsOf: oop) ~= 0 ifTrue:
  [^PrimErrInappropriate halt]].
  0 to: (self numPointerSlotsOf: objOop) - 1 do:
  [:i|
  oop := self fetchPointer: i ofObject: objOop.
  (self isNonImmediate: oop) ifTrue:
  [(oop anyMask: TopOopBit)
  ifTrue:
  [(oop := oop - TopOopBit / self bytesPerOop) >= numOutPointers ifTrue:
  [^PrimErrBadIndex halt].
  mappedOop := self fetchPointer: oop ofObject: outPointerArray]
  ifFalse:
  [(oop bitAnd: self allocationUnit - 1) ~= 0 ifTrue:
  [^PrimErrInappropriate halt].
  (mappedOop := oop + segmentStart) >= segmentLimit ifTrue:
  [^PrimErrBadIndex halt]].
  self storePointerUnchecked: i ofObject: objOop withValue: mappedOop]].
  objOop := self objectAfter: objOop limit: segmentLimit].
  ^numSegObjs negated!

Item was changed:
  ----- Method: SpurMemoryManager>>mapOopsFrom:to:outPointers:outHashes: (in category 'image segment in/out') -----
  mapOopsFrom: segStart to: segAddr outPointers: outPointerArray outHashes: savedOutHashes
  "This is part of storeImageSegmentInto:outPointers:roots:.
  Now scan, adding out pointers to the outPointersArray; all objects in arrayOfObjects
  have had their first fields set to point to their copies in segmentWordArray.  Answer
  the outIndex if the scan succeded.  Fail if outPointers is too small and answer -1.
 
  As established by copyObj:toAddr:startAt:stopAt:savedFirstFields:index:,
  the marked bit is set for all objects in the segment
  the remembered bit is set for all classes in the segment.
 
  Class indices should be set as follows (see assignClassIndicesAndPinFrom:to:outPointers:filling:)
  - class indices for classes in the segment "
  | objOop outIndex |
  outIndex := 0.
  self fillObj: outPointerArray numSlots: (self numSlotsOf: outPointerArray) with: nilObj.
  objOop := self objectStartingAt: segStart.
+ [self oop: objOop isLessThan: segAddr] whileTrue:
+ [| heapOop oop hash segIndex |
+ heapOop := self fetchClassOfNonImm: objOop.
- [objOop < segAddr] whileTrue:
- [| oop hash segIndex |
- oop := self fetchClassOfNonImm: objOop.
  "Set the classIndex of the instance.  This is a segment offset (segAddr - segStart / allocatiopnUnit) for instances of
   classes within the segment, and an outPointer index (index in outPointers + TopHashBit) for classes outside the segment."
+ (self isCopiedIntoSegment: heapOop)
- (self isMarked: oop)
  ifTrue: "oop is a class in the segment; storeImageSegmentInto:outPointers:roots: established offset is within range."
+ [oop := self fetchPointer: 0 ofObject: heapOop.
- [oop := self fetchPointer: 0 ofObject: oop.
  self assert: (self oop: oop isGreaterThanOrEqualTo: segStart andLessThan: segAddr).
  segIndex := oop - segStart / self allocationUnit + self firstClassIndexPun.
  (segIndex anyMask: TopHashBit) ifTrue: "Too many classes in the segment"
  [^-1 halt]]
  ifFalse: "oop is an outPointer; locate or allocate its oop"
+ [hash := self rawHashBitsOf: heapOop.
+ (self is: hash outPointerClassHashFor: heapOop in: outPointerArray limit: outIndex)
- [hash := self rawHashBitsOf: oop.
- (self is: hash outPointerClassHashFor: oop in: outPointerArray limit: outIndex)
  ifTrue: [segIndex := hash]
  ifFalse: "oop is a new outPointer; allocate its oop"
+ [outIndex := self newOutPointer: heapOop at: outIndex in: outPointerArray hashes: savedOutHashes.
- [outIndex := self newOutPointer: oop at: outIndex in: outPointerArray hashes: savedOutHashes.
  outIndex = 0 ifTrue: "no room in outPointers; fail"
  [^-1 halt].
+ segIndex := self rawHashBitsOf: heapOop].
- segIndex := self rawHashBitsOf: oop].
  self assert: (segIndex anyMask: TopHashBit)].
  self setClassIndexOf: objOop to: segIndex.
  0 to: (self numPointerSlotsOf: objOop) - 1 do:
  [:i|
+ heapOop := self fetchPointer: i ofObject: objOop.
+ (self isNonImmediate: heapOop) ifTrue:
+ [(self isCopiedIntoSegment: heapOop)
- oop := self fetchPointer: i ofObject: objOop.
- (self isNonImmediate: oop) ifTrue:
- [(self isMarked: oop)
  ifTrue: "oop is an object in the segment."
+ [oop := self fetchPointer: 0 ofObject: heapOop.
- [oop := self fetchPointer: 0 ofObject: oop.
  self assert: (self oop: oop isGreaterThanOrEqualTo: segStart andLessThan: segAddr).
  oop := oop - segStart]
  ifFalse: "oop is an outPointer; locate or allocate its oop"
+ [hash := self rawHashBitsOf: heapOop.
+ (self is: hash outPointerClassHashFor: heapOop in: outPointerArray limit: outIndex)
- [hash := self rawHashBitsOf: oop.
- (self is: hash outPointerClassHashFor: oop in: outPointerArray limit: outIndex)
  ifTrue: [oop := hash - TopHashBit * self bytesPerOop + TopOopBit]
  ifFalse: "oop is a new outPointer; allocate its oop"
+ [outIndex := self newOutPointer: heapOop at: outIndex in: outPointerArray hashes: savedOutHashes.
- [outIndex := self newOutPointer: oop at: outIndex in: outPointerArray hashes: savedOutHashes.
  outIndex = 0 ifTrue: "no room in outPointers; fail"
  [^-1 halt].
+ self assert: ((self rawHashBitsOf: heapOop) anyMask: TopHashBit).
+ oop := (self rawHashBitsOf: heapOop) - TopHashBit * self bytesPerOop + TopOopBit]].
- self assert: ((self rawHashBitsOf: oop) anyMask: TopHashBit).
- oop := (self rawHashBitsOf: oop) - TopHashBit * self bytesPerOop + TopOopBit]].
  self storePointerUnchecked: i ofObject: objOop withValue: oop]].
  objOop := self objectAfter: objOop limit: segAddr].
  ^outIndex!

Item was added:
+ ----- Method: SpurMemoryManager>>markAsCopiedIntoSegment: (in category 'image segment in/out') -----
+ markAsCopiedIntoSegment: anObjectInTheHeap
+ <inline: true>
+ self setIsMarkedOf: anObjectInTheHeap to: true!

Item was changed:
  ----- Method: SpurMemoryManager>>objectsReachableFromRoots: (in category 'image segment in/out') -----
  objectsReachableFromRoots: arrayOfRoots
  "This is part of storeImageSegmentInto:outPointers:roots:.
  Answer an Array of all the objects only reachable from the argument, an Array of root objects,
  starting with arrayOfRoots.  If there is no space, answer a SmallInteger whose value is the
  number of slots required.  This is used to collect the objects to include in an image segment
  on Spur, separate from creating the segment, hence simplifying the implementation.
  Thanks to Igor Stasenko for this idea."
 
  | freeChunk ptr start limit count oop objOop |
+ <var: #freeChunk type: #usqInt> "& hence start & ptr are too; limit is also because of addressAfter:"
  <inline: #never>
  self assert: (self isArray: arrayOfRoots).
  "Mark all objects except those only reachable from the arrayOfRoots by marking
  each object in arrayOfRoots and then marking all reachable objects (from the
  system roots).  This leaves unmarked only objects reachable from the arrayOfRoots.
  N.B. A side-effect of the marking is that all forwarders in arrayOfRoots will be followed."
    self assert: self allObjectsUnmarked.
  self markObjectsIn: arrayOfRoots.
  self markObjects: false.
 
  "After the mark phase all unreachable weak slots will have been nilled
  and all active ephemerons fired."
  self assert: (self isEmptyObjStack: markStack).
  self assert: (self isEmptyObjStack: weaklingStack).
  self assert: self noUnscannedEphemerons.
 
  "Use the largest free chunk to answer the result."
+ freeChunk := self allocateLargestFreeChunk. "N.B. Does /not/ update totalFreeOldSpace"
+ totalFreeOldSpace := totalFreeOldSpace - (self bytesInObject: freeChunk). "but must update so that growth in the markStack does not cause assert fails."
- freeChunk := self allocateLargestFreeChunk.
  ptr := start := freeChunk + self baseHeaderSize.
  limit := self addressAfter: freeChunk.
  count := 0.
 
  "First put the arrayOfRoots; order is important."
  count := count + 1.
  ptr < limit ifTrue:
  [self longAt: ptr put: arrayOfRoots.
  ptr := ptr + self bytesPerOop].
 
+ "Now collect the roots and the transitive closure of unmarked objects from them."
  0 to: (self numSlotsOf: arrayOfRoots) - 1 do:
+ [:rx|
+ oop := self fetchPointer: rx ofObject: arrayOfRoots.
- [:i|
- oop := self fetchPointer: i ofObject: arrayOfRoots.
  (self isNonImmediate: oop) ifTrue:
+ [self deny: (self isForwarded: oop).
+ self noCheckPush: oop onObjStack: markStack.
- [self noCheckPush: oop onObjStack: markStack]].
 
+ "Collect the unmarked objects reachable from this root."
+ [self isEmptyObjStack: markStack] whileFalse:
+ [objOop := self popObjStack: markStack.
+ count := count + 1.
+ ptr < limit ifTrue:
+ [self longAt: ptr put: objOop.
+ ptr := ptr + self bytesPerOop].
+ oop := self fetchClassOfNonImm: objOop.
+ (self isMarked: oop) ifFalse:
+ [self setIsMarkedOf: oop to: true.
+ self noCheckPush: oop onObjStack: markStack].
+ ((self isContextNonImm: objOop)
+  and: [coInterpreter isStillMarriedContext: objOop]) "widow now, before the loop"
+ ifTrue:
+ [0 to: (coInterpreter numSlotsOfMarriedContext: objOop) - 1 do:
+ [:i|
+ oop := coInterpreter fetchPointer: i ofMarriedContext: objOop.
+ ((self isImmediate: oop)
+  or: [self isMarked: oop]) ifFalse:
+ [self setIsMarkedOf: oop to: true.
+ self noCheckPush: oop onObjStack: markStack]]]
+ ifFalse:
+ [0 to: (self numPointerSlotsOf: objOop) - 1 do:
+ [:i|
+ oop := self fetchPointer: i ofObject: objOop.
+ ((self isImmediate: oop)
+  or: [self isMarked: oop]) ifFalse:
+ [self setIsMarkedOf: oop to: true.
+ self noCheckPush: oop onObjStack: markStack]]]]]].
- "Now collect the unmarked objects reachable from the roots."
- [self isEmptyObjStack: markStack] whileFalse:
- [objOop := self popObjStack: markStack.
- count := count + 1.
- ptr < limit ifTrue:
- [self longAt: ptr put: objOop.
- ptr := ptr + self bytesPerOop].
- oop := self fetchClassOfNonImm: objOop.
- (self isMarked: oop) ifFalse:
- [self setIsMarkedOf: objOop to: true.
- self noCheckPush: oop onObjStack: markStack].
- ((self isContextNonImm: objOop)
-  and: [coInterpreter isStillMarriedContext: objOop]) "widow now, before the loop"
- ifTrue:
- [0 to: (coInterpreter numSlotsOfMarriedContext: objOop) - 1 do:
- [:i|
- oop := coInterpreter fetchPointer: i ofMarriedContext: objOop.
- ((self isImmediate: oop)
-  or: [self isMarked: oop]) ifFalse:
- [self setIsMarkedOf: objOop to: true.
- self noCheckPush: oop onObjStack: markStack]]]
- ifFalse:
- [0 to: (self numPointerSlotsOf: objOop) - 1 do:
- [:i|
- oop := self fetchPointer: i ofObject: objOop.
- ((self isImmediate: oop)
-  or: [self isMarked: oop]) ifFalse:
- [self setIsMarkedOf: objOop to: true.
- self noCheckPush: oop onObjStack: markStack]]]].
 
  self unmarkAllObjects.
 
- totalFreeOldSpace := totalFreeOldSpace - (self bytesInObject: freeChunk).
  "Now try and allocate the result"
  (count > (ptr - start / self bytesPerOop) "not enough room"
  or: [limit ~= ptr and: [limit - ptr <= self allocationUnit]]) ifTrue: "can't split a single word"
+ [self freeObject: freeChunk.
- [self freeChunkWithBytes: (self bytesInObject: freeChunk) at: (self startOfObject: freeChunk).
  self checkFreeSpace: GCModeImageSegment.
  ^self integerObjectOf: count].
  "There's room; set the format, & classIndex and shorten."
  self setFormatOf: freeChunk to: self arrayFormat.
  self setClassIndexOf: freeChunk to: ClassArrayCompactIndex.
  self shorten: freeChunk toIndexableSize: count.
  (self isForwarded: freeChunk) ifTrue:
  [freeChunk := self followForwarded: freeChunk].
  self possibleRootStoreInto: freeChunk.
  self checkFreeSpace: GCModeImageSegment.
  self runLeakCheckerFor: GCModeImageSegment.
  ^freeChunk!

Item was changed:
  ----- Method: SpurMemoryManager>>return:restoringObjectsIn:savedFirstFields:and:savedHashes: (in category 'image segment in/out') -----
  return: errCode restoringObjectsIn: firstArray savedFirstFields: savedFirstFields and: secondArray savedHashes: savedHashes
  <inline: false>
  "This is part of storeImageSegmentInto:outPointers:roots:."
+ self cCode: [] inSmalltalk: [errCode ~= 0 ifTrue: [self halt]].
  self restoreObjectsIn: firstArray upTo: -1 savedFirstFields: savedFirstFields.
  self restoreObjectsIn: secondArray savedHashes: savedHashes.
  self runLeakCheckerFor: GCModeImageSegment.
  self assert: self allObjectsUnmarked.
  ^errCode!

Item was changed:
  ----- Method: SpurMemoryManager>>return:restoringObjectsIn:upTo:savedFirstFields: (in category 'image segment in/out') -----
  return: errCode restoringObjectsIn: firstArray upTo: limitOrTag savedFirstFields: savedFirstFields
  <inline: false>
  "This is part of storeImageSegmentInto:outPointers:roots:."
+ self cCode: [] inSmalltalk: [errCode ~= 0 ifTrue: [self halt]].
  self restoreObjectsIn: firstArray upTo: limitOrTag savedFirstFields: savedFirstFields.
  self runLeakCheckerFor: GCModeImageSegment.
  self assert: self allObjectsUnmarked.
  ^errCode!

Item was changed:
  ----- Method: SpurMemoryManager>>storeImageSegmentInto:outPointers:roots: (in category 'image segment in/out') -----
  storeImageSegmentInto: segmentWordArrayArg outPointers: outPointerArrayArg roots: arrayOfRootsArg
  "This primitive is called from Squeak as...
  <imageSegment> storeSegmentFor: arrayOfRoots into: aWordArray outPointers: anArray.
 
  This primitive will store a binary image segment (in the same format as objects in the heap) of the
  set of objects in arrayOfObjects.  All pointers from within the set to objects outside the set will be
  copied into the array of outPointers.  In their place in the image segment will be an oop equal to the
  offset in the outPointer array (the first would be 8), but with the high bit set.
 
  Since Spur has a class table the load primitive must insert classes that have instances into the
  class table.  This primitive marks such classes using the isRemembered bit, which isn't meaningful
  as a remembered bit in the segment.
 
  The primitive expects the segmentWordArray and outPointerArray to be more than adequately long.
  In this case it returns normally, and truncates the two arrays to exactly the right size.
 
  The primitive can fail for the following reasons with the specified failure codes:
  PrimErrGenericError: the segmentWordArray is too small for the version stamp
  PrimErrWritePastObject: the segmentWordArray is too small to contain the reachable objects
  PrimErrBadIndex: the outPointerArray is too small
  PrimErrNoMemory: additional allocations failed
  PrimErrLimitExceeded: there is no room in the hash field to store out pointer indices or class references."
  <inline: false>
  | segmentWordArray outPointerArray arrayOfRoots
   arrayOfObjects savedFirstFields savedOutHashes segStart segAddr endSeg outIndex numClassesInSegment |
+ <var: 'segAddr' type: #usqInt>
  ((self isObjImmutable: segmentWordArrayArg)
  or: [self isObjImmutable: outPointerArrayArg]) ifTrue:
  [^PrimErrNoModification].
  "Since segmentWordArrayArg & outPointerArrayArg may get shortened, they can't be pinned."
  ((self isPinned: segmentWordArrayArg)
  or: [self isPinned: outPointerArrayArg]) ifTrue:
  [^PrimErrObjectIsPinned].
  (self numSlotsOf: outPointerArrayArg) > self maxIdentityHash ifTrue:
  [^PrimErrLimitExceeded].
 
  self runLeakCheckerFor: GCModeImageSegment.
 
  "First scavenge to collect any new space garbage that refers to the graph."
  self scavengingGC.
  segmentWordArray := self updatePostScavenge: segmentWordArrayArg.
  outPointerArray := self updatePostScavenge: outPointerArrayArg.
  arrayOfRoots := self updatePostScavenge: arrayOfRootsArg.
+ self deny: (self forwardersIn: outPointerArray).
+ self deny: (self forwardersIn: arrayOfRoots).
 
  "Now compute the transitive closure, collecting the sequence of objects to be stored in the arrayOfObjects array.
  Included in arrayOfObjects are the arrayOfRoots and all its contents.  All objects have been unmarked."
  arrayOfObjects := self objectsReachableFromRoots: arrayOfRoots.
  arrayOfObjects ifNil:
  [^PrimErrNoMemory].
 
  self assert: self allObjectsUnmarked. "work to be done when the incremental GC is written"
+ self deny: (self forwardersIn: arrayOfObjects).
 
  "Both to expand the max size of segment and to reduce the length of the
  load-time pass that adds classes to the class table, move classes to the
  front of arrayOfObjects, leaving the root array as the first element."
  numClassesInSegment := self moveClassesForwardsIn: arrayOfObjects.
 
  "The scheme is to copy the objects into segmentWordArray, and then map the oops in segmentWordArray.
  Therefore the primitive needs to both map efficiently originals to copies in segmentWordArray and
  be able to undo any side-effects if the primitive fails because either segmentWordArray or outPointerArray
  is too small.  The mapping is done by having the objects to be stored in arrayOfObjects refer to their mapped
  locations through their first field, just like a forwarding pointer, but without becoming a forwarder, saving their
  first field in savedFirstFields, and the objects in outPointerArray pointing to their locations in the outPointerArray
  through their identityHashes, saved in savedOutHashes.
  Since arrayOfObjects and its savedFirstFields, and outPointerArray and its saved hashes, can be enumerated
  side-by-side, the hashes can be restored to the originals.  So the first field of the heap object corresponding to
  an object in arrayOfObjects is set to its location in segmentWordArray, and the hash of an object in outPointerArray
  is set to its index in outPointerArray plus the top hash bit.  Classes in arrayOfObjects have their marked bit set.
  Oops in objects in segmentWordArray are therefore mapped by accessing the original oop, and following its first
  field. Class indices in segmentWordArray are mapped by fetching the original class, and testing its marked bit.
  If marked, the first field is followed to access the class copy in the segment.  Out pointers (objects and classes,
  which are unmarked), the object's identityHash is set (eek!!!!) to its index in the outPointerArray. So savedOutHashes
  parallels the outPointerArray. The saved hash array is initialized with an out-of-range hash value so that the first
  unused entry can be identified."
 
  savedFirstFields := self allocateSlots: (self numSlotsOf: arrayOfObjects)
  format: self wordIndexableFormat
  classIndex: self wordSizeClassIndexPun.
  savedOutHashes := self allocateSlots: (self numSlotsForBytes: (self numSlotsOf: outPointerArray) * 4)
  format: self firstLongFormat
  classIndex: self thirtyTwoBitLongsClassIndexPun.
  (savedFirstFields isNil or: [savedOutHashes isNil]) ifTrue:
  [self freeObject: arrayOfObjects.
  ^PrimErrNoMemory].
 
  self fillObj: savedFirstFields numSlots: (self numSlotsOf: savedFirstFields) with: 0.
  self fillObj: savedOutHashes numSlots: (self numSlotsOf: savedOutHashes) with: self savedOutHashFillValue.
 
  segAddr := segmentWordArray + self baseHeaderSize.
  endSeg := self addressAfter: segmentWordArray.
 
  "Write a version number for byte order and version check."
  segAddr >= endSeg ifTrue: [^PrimErrGenericFailure].
  self long32At: segAddr put: self imageSegmentVersion.
  self long32At: segAddr + 4 put: self imageSegmentVersion.
  segStart := segAddr := segAddr + self allocationUnit.
 
  "Copy all reachable objects to the segment, setting the marked bit for all objects (clones) in the segment,
  and the remembered bit for all classes (clones) in the segment."
  0 to: (self numSlotsOf: arrayOfObjects) - 1 do:
  [:i| | newSegAddrOrError objOop |
  "Check that classes in the segment are addressible.  Since the top bit of the hash field is used to tag
  classes external to the segment, the segment offset must not inadvertently set this bit.  This limit still
  allows for a million or more classes."
  (i = numClassesInSegment
  and: [segAddr - segStart / self allocationUnit + self lastClassIndexPun >= TopHashBit]) ifTrue:
  [^self return: PrimErrLimitExceeded
  restoringObjectsIn: arrayOfObjects upTo: i savedFirstFields: savedFirstFields].
  objOop := self fetchPointer: i ofObject: arrayOfObjects.
  self deny: ((self isImmediate: objOop) or: [self isForwarded: objOop]).
  newSegAddrOrError := self copyObj: objOop
  toAddr: segAddr
  startAt: segStart
  stopAt: endSeg
  savedFirstFields: savedFirstFields
  index: i.
+ (self oop: newSegAddrOrError isLessThan: segStart) ifTrue:
- newSegAddrOrError < segStart ifTrue:
  [^self return: newSegAddrOrError
  restoringObjectsIn: arrayOfObjects upTo: i savedFirstFields: savedFirstFields].
  segAddr := newSegAddrOrError].
 
  "Check that it can be safely shortened."
  (endSeg ~= segAddr
  and: [endSeg - segAddr < (self baseHeaderSize + self bytesPerOop)]) ifTrue:
  [^self return: PrimErrWritePastObject
  restoringObjectsIn: arrayOfObjects upTo: -1 savedFirstFields: savedFirstFields].
 
  "Now scan, adding out pointers to the outPointersArray; all objects in arrayOfObjects
  have their first field pointing to the corresponding copy in segmentWordArray."
  (outIndex := self mapOopsFrom: segStart
  to: segAddr
  outPointers: outPointerArray
  outHashes: savedOutHashes) < 0 ifTrue: "no room in outPointers; fail"
  [^self return: PrimErrBadIndex
  restoringObjectsIn: arrayOfObjects savedFirstFields: savedFirstFields
  and: outPointerArray savedHashes: savedOutHashes].
 
  "We're done.  Shorten the results, restore hashes and return."
  self shorten: segmentWordArray toIndexableSize: segAddr - (segmentWordArray + self baseHeaderSize) / 4.
  self shorten: outPointerArray toIndexableSize: outIndex.
  ^self return: PrimNoErr
  restoringObjectsIn: arrayOfObjects savedFirstFields: savedFirstFields
  and: outPointerArray savedHashes: savedOutHashes!

Item was changed:
  ----- Method: SpurPlanningCompactor>>useSegmentForSavedFirstFieldsSpace: (in category 'space management') -----
  useSegmentForSavedFirstFieldsSpace: spaceEstimate
  "Attempt to allocate a memory segment large enough to hold the savedFirstFieldsSpace.
  Invoked when neither eden nor a large free chunk are found to be big enough for the job."
+ | roundedSize allocatedSize |
- | allocatedSize |
  <var: #segAddress type: #'void *'>
+ roundedSize := spaceEstimate + 1023 // 1024 * 1024.
  (manager "sent to the manager so that the simulator can increase memory to simulate a new segment"
+ sqAllocateMemorySegmentOfSize: roundedSize
+ Above: (manager segmentManager firstGapOfSizeAtLeast: roundedSize)
- sqAllocateMemorySegmentOfSize: spaceEstimate
- Above: (self firstGapOfSizeAtLeast: spaceEstimate)
  AllocatedSizeInto: (self cCode: [self addressOf: allocatedSize]
  inSmalltalk: [[:sz| allocatedSize := sz]])) ifNotNil:
  [:segAddress|
  savedFirstFieldsSpace
  start: segAddress asUnsignedIntegerPtr;
  limit: segAddress asUnsignedIntegerPtr + allocatedSize.
  savedFirstFieldsSpaceNotInOldSpace := true.
  self assert: self savedFirstFieldsSpaceWasAllocated.
  ^true].
  ^false!