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

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

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

Name: VMMaker.oscog-eem.2522
Author: eem
Time: 28 February 2019, 12:29:38.701933 pm
UUID: 9daf994d-33ae-4c62-a695-24fa694f3035
Ancestors: VMMaker.oscog-eem.2521

Spur:
Fix image segment storage when there is insufficient contguous space to store teh array of objects to be included in a segment.  I wrote the code to answer a suitable error object (a SmallInteger of the required size), but forgot to handle tyhe return, hence causing horrible crashes as the VM attempted to access objects in a SmallInteger.  this was Max Leske's failing segment storage test case (a 66.5Mb segment).

Handle the case by introducing a new error code (PrimErrNeedCompact) and having the primitive perform a full GC when it gets the error code, and then to retry segment storage.

Have printFreeTree/printFreeChunk:printAsTreeNode: mark the root node with a '+'.

Fix some slips in free chunk integrity checking.

Clément, I think "lazy" in the comment in SpurMemoryManager>>fullGC should be "eager", right?  I'll leave it to you to fix.  Also IO don't understand the SpurMemoryManager send in "self SpurMemoryManager globalGarbageCollect.".  What's going on here?

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

Item was changed:
  ----- Method: InterpreterPrimitives>>primitiveStoreImageSegment (in category 'image segment in/out') -----
  primitiveStoreImageSegment
  "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 the Squeak image file) of the receiver and every object in its proper tree of subParts (ie, that is not refered to from anywhere else outside the tree).  All pointers from within the tree to objects outside the tree 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 4). but with the high bit set."
 
  "The primitive expects the array and wordArray to be more than adequately long.  In this case it returns normally, and truncates the two arrays to exactly the right size.  To simplify truncation, both incoming arrays are required to be 256 bytes or more long (ie with 3-word headers).  If either array is too small, the primitive will fail, but in no other case.
 
  During operation of the primitive, it is necessary to convert from both internal and external oops to their mapped values.  To make this fast, the headers of the original objects in question are replaced by the mapped values (and this is noted by adding the forbidden XX header type).  Tables are kept of both kinds of oops, as well as of the original headers for restoration.
 
  To be specific, there are two similar two-part tables, the outpointer array, and one in the upper fifth of the segmentWordArray.  Each grows oops from the bottom up, and preserved headers from halfway up.
 
  In case of either success or failure, the headers must be restored.  In the event of primitive failure, the table of outpointers must also be nilled out (since the garbage in the high half will not have been discarded."
 
  | outPointerArray segmentWordArray arrayOfRoots ecode |
 
  outPointerArray := self stackTop.
  segmentWordArray := self stackValue: 1.
  arrayOfRoots := self stackValue: 2.
 
  "Essential type checks"
  ((objectMemory isArray: arrayOfRoots) "Must be indexable pointers"
  and: [(objectMemory isArray: outPointerArray) "Must be indexable pointers"
  and: [objectMemory isWords: segmentWordArray]]) "Must be indexable words"
  ifFalse: [^self primitiveFail].
 
  ecode := objectMemory storeImageSegmentInto: segmentWordArray outPointers: outPointerArray roots: arrayOfRoots.
+ (objectMemory hasSpurMemoryManagerAPI
+ and: [ecode = PrimErrNeedCompaction]) ifTrue:
+ [objectMemory fullGC.
+ outPointerArray := self stackTop.
+ segmentWordArray := self stackValue: 1.
+ arrayOfRoots := self stackValue: 2.
+ ecode := objectMemory storeImageSegmentInto: segmentWordArray outPointers: outPointerArray roots: arrayOfRoots].
  ecode = PrimNoErr
  ifTrue: [self pop: 3]  "...leaving the receiver on the stack as return value"
  ifFalse: [self primitiveFailFor: ecode]!

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: fieldOop)) ~= 0]) ifTrue:
- 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 isLilliputianSize: (self bytesInObject: obj)) 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: ' @ 1 = '; printHex: fieldOop; print: ' is mapped'; cr.
- 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:
- 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]) 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.
- [(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 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.
- 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]]]]].
- 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>>printFreeChunk:printAsTreeNode: (in category 'debug printing') -----
  printFreeChunk: freeChunk printAsTreeNode: printAsTreeNode
  | numBytes |
  numBytes := self bytesInObject: freeChunk.
  coInterpreter
  print: 'freeChunk '; printHexPtrnp: freeChunk.
  printAsTreeNode ifTrue:
+ [coInterpreter
+ print: ((freeChunk = (freeLists at: 0)) ifTrue: [' + '] ifFalse: [' - ']);
+ printHexPtrnp:(self addressAfter: freeChunk)].
- [coInterpreter print: ' - '; printHexPtrnp:(self addressAfter: freeChunk)].
  coInterpreter
  print: ' bytes '; printNum: numBytes;
  print: ' next '; printHexPtrnp: (self fetchPointer: self freeChunkNextIndex
  ofFreeChunk: freeChunk).
  (self isLilliputianSize: numBytes) ifFalse:
  [coInterpreter
  print: ' prev '; printHexPtrnp: (self fetchPointer: self freeChunkPrevIndex
  ofFreeChunk: freeChunk).].
  (numBytes >= (self numFreeLists * self allocationUnit)
  and: [printAsTreeNode]) ifTrue:
  [coInterpreter
  print: ' ^ '; printHexPtrnp: (self fetchPointer: self freeChunkParentIndex
  ofFreeChunk: freeChunk);
  print: ' < '; printHexPtrnp: (self fetchPointer: self freeChunkSmallerIndex
  ofFreeChunk: freeChunk);
  print: ' > '; printHexPtrnp: (self fetchPointer: self freeChunkLargerIndex
  ofFreeChunk: freeChunk)].
  coInterpreter cr!

Item was changed:
  ----- Method: SpurMemoryManager>>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].
+ "If objectsReachableFromRoots: answers an integer there is not enough continuous free space in which to allocate the
+ reachable objects.  If there is sufficient free space then answer an error code to prompt a compacting GC and a retry."
+ (self isIntegerObject: arrayOfObjects) ifTrue:
+ [totalFreeOldSpace - self allocationUnit >= (self integerValueOf: arrayOfObjects) ifTrue:
+ [^PrimErrNeedCompaction].
+ ^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.
+ (savedFirstFields notNil and: [self isInOldSpace: savedFirstFields]) ifTrue:
+ [self freeObject: savedFirstFields].
+ (savedOutHashes notNil and: [self isInOldSpace: savedOutHashes]) ifTrue:
+ [self freeObject: savedOutHashes].
  ^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.
 
  self assert: arrayOfRoots = (self fetchPointer: 0 ofObject: arrayOfObjects).
 
  "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 addressable.  Since the top bit of the hash field is used to tag
- "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
  stopAt: endSeg
  savedFirstFields: savedFirstFields
  index: i.
  (self oop: newSegAddrOrError isLessThan: 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:
  SharedPool subclass: #VMBasicConstants
  instanceVariableNames: ''
+ classVariableNames: 'BaseHeaderSize BytecodeSetHasExtensions BytesPerOop BytesPerWord COGMTVM COGVM CloneOnGC CloneOnScavenge DisownVMForFFICall DisownVMForThreading DisownVMLockOutFullGC DoAssertionChecks DoExpensiveAssertionChecks GCCheckPrimCall GCModeBecome GCModeFreeSpace GCModeFull GCModeImageSegment GCModeIncremental GCModeNewSpace HashMultiplyConstant HashMultiplyMask IMMUTABILITY LowcodeVM MULTIPLEBYTECODESETS NewspeakVM PharoVM PrimErrBadArgument PrimErrBadIndex PrimErrBadMethod PrimErrBadNumArgs PrimErrBadReceiver PrimErrCallbackError PrimErrFFIException PrimErrGenericFailure PrimErrInappropriate PrimErrLimitExceeded PrimErrNamedInternal PrimErrNeedCompaction PrimErrNoCMemory PrimErrNoMemory PrimErrNoModification PrimErrNotFound PrimErrOSError PrimErrObjectIsPinned PrimErrObjectMayMove PrimErrObjectMoved PrimErrObjectNotPinned PrimErrUnsupported PrimErrWritePastObject PrimNoErr SPURVM STACKVM SistaVM TempVectReadBarrier VMBIGENDIAN'
- classVariableNames: 'BaseHeaderSize BytecodeSetHasExtensions BytesPerOop BytesPerWord COGMTVM COGVM CloneOnGC CloneOnScavenge DisownVMForFFICall DisownVMForThreading DisownVMLockOutFullGC DoAssertionChecks DoExpensiveAssertionChecks GCCheckPrimCall GCModeBecome GCModeFreeSpace GCModeFull GCModeImageSegment GCModeIncremental GCModeNewSpace HashMultiplyConstant HashMultiplyMask IMMUTABILITY LowcodeVM MULTIPLEBYTECODESETS NewspeakVM PharoVM PrimErrBadArgument PrimErrBadIndex PrimErrBadMethod PrimErrBadNumArgs PrimErrBadReceiver PrimErrCallbackError PrimErrFFIException PrimErrGenericFailure PrimErrInappropriate PrimErrLimitExceeded PrimErrNamedInternal PrimErrNoCMemory PrimErrNoMemory PrimErrNoModification PrimErrNotFound PrimErrOSError PrimErrObjectIsPinned PrimErrObjectMayMove PrimErrObjectMoved PrimErrObjectNotPinned PrimErrUnsupported PrimErrWritePastObject PrimNoErr SPURVM STACKVM SistaVM TempVectReadBarrier VMBIGENDIAN'
  poolDictionaries: ''
  category: 'VMMaker-Interpreter'!
 
  !VMBasicConstants commentStamp: '<historical>' prior: 0!
  I am a shared pool for basic constants upon which the VM as a whole depends.
 
  self ensureClassPool.
  self classPool declare: #BytesPerWord from: VMSqueakV3ObjectRepresentationConstants classPool.
  self classPool declare: #BaseHeaderSize from: VMSqueakV3ObjectRepresentationConstants classPool
  (ObjectMemory classPool keys select: [:k| k beginsWith: 'Byte']) do:
  [:k| self classPool declare: k from: ObjectMemory classPool]!

Item was changed:
  ----- Method: VMClass class>>initializePrimitiveErrorCodes (in category 'initialization') -----
  initializePrimitiveErrorCodes
  "Define the VM's primitive error codes.  N.B. these are
  replicated in platforms/Cross/vm/sqVirtualMachine.h."
  "VMClass initializePrimitiveErrorCodes"
  | pet |
  PrimErrTableIndex := 51. "Zero-relative"
  "See SmalltalkImage>>recreateSpecialObjectsArray for the table definition.
  If the table exists and is large enough the corresponding entry is returned as
  the primitive error, otherwise the error is answered numerically."
  pet := Smalltalk specialObjectsArray at: PrimErrTableIndex + 1 ifAbsent: [#()].
  pet isArray ifFalse: [pet := #()].
  PrimNoErr := 0. "for helper methods that need to answer success or an error code."
  PrimErrGenericFailure := pet indexOf: nil ifAbsent: 1.
  PrimErrBadReceiver := pet indexOf: #'bad receiver' ifAbsent: 2.
  PrimErrBadArgument := pet indexOf: #'bad argument' ifAbsent: 3.
  PrimErrBadIndex := pet indexOf: #'bad index' ifAbsent: 4.
  PrimErrBadNumArgs := pet indexOf: #'bad number of arguments' ifAbsent: 5.
  PrimErrInappropriate := pet indexOf: #'inappropriate operation' ifAbsent: 6.
  PrimErrUnsupported := pet indexOf: #'unsupported operation' ifAbsent: 7.
  PrimErrNoModification := pet indexOf: #'no modification' ifAbsent: 8.
  PrimErrNoMemory := pet indexOf: #'insufficient object memory' ifAbsent: 9.
  PrimErrNoCMemory := pet indexOf: #'insufficient C memory' ifAbsent: 10.
  PrimErrNotFound := pet indexOf: #'not found' ifAbsent: 11.
  PrimErrBadMethod := pet indexOf: #'bad method' ifAbsent: 12.
  PrimErrNamedInternal := pet indexOf: #'internal error in named primitive machinery' ifAbsent: 13.
  PrimErrObjectMayMove := pet indexOf: #'object may move' ifAbsent: 14.
  PrimErrLimitExceeded := pet indexOf: #'resource limit exceeded' ifAbsent: 15.
  PrimErrObjectIsPinned := pet indexOf: #'object is pinned' ifAbsent: 16.
  PrimErrWritePastObject := pet indexOf: #'primitive write beyond end of object' ifAbsent: 17.
  PrimErrObjectMoved := pet indexOf: #'object moved' ifAbsent: 18.
  PrimErrObjectNotPinned := pet indexOf: #'object not pinned' ifAbsent: 19.
  PrimErrCallbackError := pet indexOf: #'error in callback' ifAbsent: 20.
  PrimErrOSError := pet indexOf: #'operating system error' ifAbsent: 21.
+ PrimErrFFIException := pet indexOf: #'ffi call exception' ifAbsent: 22.
+ PrimErrNeedCompaction := pet indexOf: #'heap compaction needed' ifAbsent: 23 "N.B. This is currently an internal error in Spur image segment saving."!
- PrimErrFFIException := pet indexOf: #'ffi call exception' ifAbsent: 22!